]>
Commit | Line | Data |
---|---|---|
84481f76 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
b497b460 | 3 | -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- |
84481f76 RK |
4 | -- -- |
5 | -- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
748086b7 | 9 | -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- |
84481f76 RK |
10 | -- -- |
11 | -- GNARL is free software; you can redistribute it and/or modify it under -- | |
12 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
748086b7 JJ |
13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- | |
84481f76 | 15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
748086b7 | 16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
84481f76 | 17 | -- -- |
748086b7 JJ |
18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- |
19 | -- additional permissions described in the GCC Runtime Library Exception, -- | |
20 | -- version 3.1, as published by the Free Software Foundation. -- | |
21 | -- -- | |
22 | -- You should have received a copy of the GNU General Public License and -- | |
23 | -- a copy of the GCC Runtime Library Exception along with this program; -- | |
24 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- | |
25 | -- <http://www.gnu.org/licenses/>. -- | |
84481f76 | 26 | -- -- |
91ed4b19 NN |
27 | -- GNARL was developed by the GNARL team at Florida State University. -- |
28 | -- Extensive contributions were provided by Ada Core Technologies, Inc. -- | |
84481f76 RK |
29 | -- -- |
30 | ------------------------------------------------------------------------------ | |
31 | ||
32 | -- This is a Solaris (native) version of this package | |
33 | ||
366b8af7 RD |
34 | -- This package contains all the GNULL primitives that interface directly with |
35 | -- the underlying OS. | |
84481f76 RK |
36 | |
37 | pragma Polling (Off); | |
366b8af7 RD |
38 | -- Turn off polling, we do not want ATC polling to take place during tasking |
39 | -- operations. It causes infinite loops and other problems. | |
84481f76 | 40 | |
366b8af7 | 41 | with Ada.Unchecked_Deallocation; |
84481f76 | 42 | |
366b8af7 | 43 | with Interfaces.C; |
3b91d88e | 44 | |
366b8af7 RD |
45 | with System.Tasking.Debug; |
46 | with System.Interrupt_Management; | |
3b91d88e | 47 | with System.OS_Primitives; |
366b8af7 | 48 | with System.Task_Info; |
84481f76 | 49 | |
3b91d88e | 50 | pragma Warnings (Off); |
dae22b53 | 51 | with System.OS_Lib; |
3b91d88e AC |
52 | pragma Warnings (On); |
53 | ||
72774950 | 54 | with System.Soft_Links; |
72774950 JR |
55 | -- We use System.Soft_Links instead of System.Tasking.Initialization |
56 | -- because the later is a higher level package that we shouldn't depend on. | |
57 | -- For example when using the restricted run time, it is replaced by | |
58 | -- System.Tasking.Restricted.Stages. | |
59 | ||
84481f76 RK |
60 | package body System.Task_Primitives.Operations is |
61 | ||
72774950 JR |
62 | package SSL renames System.Soft_Links; |
63 | ||
84481f76 RK |
64 | use System.Tasking.Debug; |
65 | use System.Tasking; | |
66 | use Interfaces.C; | |
67 | use System.OS_Interface; | |
68 | use System.Parameters; | |
84481f76 RK |
69 | use System.OS_Primitives; |
70 | ||
fbf5a39b AC |
71 | ---------------- |
72 | -- Local Data -- | |
73 | ---------------- | |
84481f76 | 74 | |
84481f76 RK |
75 | -- The following are logically constants, but need to be initialized |
76 | -- at run time. | |
77 | ||
b5e792e2 AC |
78 | Environment_Task_Id : Task_Id; |
79 | -- A variable to hold Task_Id for the environment task. | |
80 | -- If we use this variable to get the Task_Id, we need the following | |
84481f76 RK |
81 | -- ATCB_Key only for non-Ada threads. |
82 | ||
83 | Unblocked_Signal_Mask : aliased sigset_t; | |
84 | -- The set of signals that should unblocked in all tasks | |
85 | ||
86 | ATCB_Key : aliased thread_key_t; | |
b5e792e2 | 87 | -- Key used to find the Ada Task_Id associated with a thread, |
84481f76 RK |
88 | -- at least for C threads unknown to the Ada run-time system. |
89 | ||
07fc65c4 GB |
90 | Single_RTS_Lock : aliased RTS_Lock; |
91 | -- This is a lock to allow only one thread of control in the RTS at | |
92 | -- a time; it is used to execute in mutual exclusion from all other tasks. | |
93 | -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List | |
84481f76 RK |
94 | |
95 | Next_Serial_Number : Task_Serial_Number := 100; | |
96 | -- We start at 100, to reserve some special values for | |
97 | -- using in error checking. | |
98 | -- The following are internal configuration constants needed. | |
99 | ||
fbf5a39b AC |
100 | ---------------------- |
101 | -- Priority Support -- | |
102 | ---------------------- | |
84481f76 | 103 | |
84481f76 RK |
104 | Priority_Ceiling_Emulation : constant Boolean := True; |
105 | -- controls whether we emulate priority ceiling locking | |
106 | ||
107 | -- To get a scheduling close to annex D requirements, we use the real-time | |
12a13f01 | 108 | -- class provided for LWPs and map each task/thread to a specific and |
84481f76 RK |
109 | -- unique LWP (there is 1 thread per LWP, and 1 LWP per thread). |
110 | ||
111 | -- The real time class can only be set when the process has root | |
12a13f01 | 112 | -- privileges, so in the other cases, we use the normal thread scheduling |
84481f76 RK |
113 | -- and priority handling. |
114 | ||
115 | Using_Real_Time_Class : Boolean := False; | |
f3d0f304 | 116 | -- indicates whether the real time class is being used (i.e. the process |
12a13f01 | 117 | -- has root privileges). |
84481f76 RK |
118 | |
119 | Prio_Param : aliased struct_pcparms; | |
120 | -- Hold priority info (Real_Time) initialized during the package | |
121 | -- elaboration. | |
122 | ||
fbf5a39b AC |
123 | ----------------------------------- |
124 | -- External Configuration Values -- | |
125 | ----------------------------------- | |
84481f76 | 126 | |
8dbb621e | 127 | Time_Slice_Val : Integer; |
84481f76 RK |
128 | pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); |
129 | ||
130 | Locking_Policy : Character; | |
131 | pragma Import (C, Locking_Policy, "__gl_locking_policy"); | |
132 | ||
133 | Dispatching_Policy : Character; | |
134 | pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); | |
135 | ||
fbf5a39b | 136 | Foreign_Task_Elaborated : aliased Boolean := True; |
8dbb621e | 137 | -- Used to identified fake tasks (i.e., non-Ada Threads) |
84481f76 | 138 | |
84481f76 RK |
139 | ----------------------- |
140 | -- Local Subprograms -- | |
141 | ----------------------- | |
142 | ||
8a6a52dc | 143 | function sysconf (name : System.OS_Interface.int) return processorid_t; |
84481f76 RK |
144 | pragma Import (C, sysconf, "sysconf"); |
145 | ||
146 | SC_NPROCESSORS_CONF : constant System.OS_Interface.int := 14; | |
147 | ||
8a6a52dc AC |
148 | function Num_Procs |
149 | (name : System.OS_Interface.int := SC_NPROCESSORS_CONF) | |
150 | return processorid_t renames sysconf; | |
84481f76 RK |
151 | |
152 | procedure Abort_Handler | |
153 | (Sig : Signal; | |
d90e94c7 JM |
154 | Code : not null access siginfo_t; |
155 | Context : not null access ucontext_t); | |
fbf5a39b AC |
156 | -- Target-dependent binding of inter-thread Abort signal to |
157 | -- the raising of the Abort_Signal exception. | |
158 | -- See also comments in 7staprop.adb | |
84481f76 | 159 | |
84481f76 RK |
160 | ------------ |
161 | -- Checks -- | |
162 | ------------ | |
163 | ||
8a6a52dc AC |
164 | function Check_Initialize_Lock |
165 | (L : Lock_Ptr; | |
166 | Level : Lock_Level) return Boolean; | |
84481f76 RK |
167 | pragma Inline (Check_Initialize_Lock); |
168 | ||
169 | function Check_Lock (L : Lock_Ptr) return Boolean; | |
170 | pragma Inline (Check_Lock); | |
171 | ||
172 | function Record_Lock (L : Lock_Ptr) return Boolean; | |
173 | pragma Inline (Record_Lock); | |
174 | ||
175 | function Check_Sleep (Reason : Task_States) return Boolean; | |
176 | pragma Inline (Check_Sleep); | |
177 | ||
178 | function Record_Wakeup | |
8a6a52dc | 179 | (L : Lock_Ptr; |
84481f76 RK |
180 | Reason : Task_States) return Boolean; |
181 | pragma Inline (Record_Wakeup); | |
182 | ||
183 | function Check_Wakeup | |
b5e792e2 | 184 | (T : Task_Id; |
84481f76 RK |
185 | Reason : Task_States) return Boolean; |
186 | pragma Inline (Check_Wakeup); | |
187 | ||
188 | function Check_Unlock (L : Lock_Ptr) return Boolean; | |
6e937c1c | 189 | pragma Inline (Check_Unlock); |
84481f76 RK |
190 | |
191 | function Check_Finalize_Lock (L : Lock_Ptr) return Boolean; | |
192 | pragma Inline (Check_Finalize_Lock); | |
193 | ||
fbf5a39b AC |
194 | -------------------- |
195 | -- Local Packages -- | |
196 | -------------------- | |
84481f76 | 197 | |
fbf5a39b | 198 | package Specific is |
84481f76 | 199 | |
b5e792e2 | 200 | procedure Initialize (Environment_Task : Task_Id); |
fbf5a39b | 201 | pragma Inline (Initialize); |
8dbb621e | 202 | -- Initialize various data needed by this package |
84481f76 | 203 | |
fbf5a39b AC |
204 | function Is_Valid_Task return Boolean; |
205 | pragma Inline (Is_Valid_Task); | |
206 | -- Does executing thread have a TCB? | |
84481f76 | 207 | |
b5e792e2 | 208 | procedure Set (Self_Id : Task_Id); |
fbf5a39b | 209 | pragma Inline (Set); |
8dbb621e | 210 | -- Set the self id for the current task |
84481f76 | 211 | |
b5e792e2 | 212 | function Self return Task_Id; |
fbf5a39b | 213 | pragma Inline (Self); |
8dbb621e | 214 | -- Return a pointer to the Ada Task Control Block of the calling task |
84481f76 | 215 | |
fbf5a39b | 216 | end Specific; |
84481f76 | 217 | |
fbf5a39b | 218 | package body Specific is separate; |
8dbb621e | 219 | -- The body of this package is target specific |
84481f76 | 220 | |
fbf5a39b AC |
221 | --------------------------------- |
222 | -- Support for foreign threads -- | |
223 | --------------------------------- | |
84481f76 | 224 | |
b5e792e2 | 225 | function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; |
8dbb621e | 226 | -- Allocate and Initialize a new ATCB for the current Thread |
84481f76 | 227 | |
fbf5a39b | 228 | function Register_Foreign_Thread |
b5e792e2 | 229 | (Thread : Thread_Id) return Task_Id is separate; |
84481f76 | 230 | |
fbf5a39b AC |
231 | ------------ |
232 | -- Checks -- | |
233 | ------------ | |
84481f76 | 234 | |
fbf5a39b | 235 | Check_Count : Integer := 0; |
fbf5a39b AC |
236 | Lock_Count : Integer := 0; |
237 | Unlock_Count : Integer := 0; | |
84481f76 | 238 | |
84481f76 RK |
239 | ------------------- |
240 | -- Abort_Handler -- | |
241 | ------------------- | |
242 | ||
84481f76 RK |
243 | procedure Abort_Handler |
244 | (Sig : Signal; | |
d90e94c7 JM |
245 | Code : not null access siginfo_t; |
246 | Context : not null access ucontext_t) | |
84481f76 | 247 | is |
fbf5a39b AC |
248 | pragma Unreferenced (Sig); |
249 | pragma Unreferenced (Code); | |
250 | pragma Unreferenced (Context); | |
251 | ||
b5e792e2 | 252 | Self_ID : constant Task_Id := Self; |
84481f76 RK |
253 | Old_Set : aliased sigset_t; |
254 | ||
91b1417d | 255 | Result : Interfaces.C.int; |
67ce0d7e | 256 | pragma Warnings (Off, Result); |
91b1417d | 257 | |
84481f76 | 258 | begin |
fbf5a39b AC |
259 | -- It is not safe to raise an exception when using ZCX and the GCC |
260 | -- exception handling mechanism. | |
261 | ||
262 | if ZCX_By_Default and then GCC_ZCX_Support then | |
263 | return; | |
264 | end if; | |
84481f76 RK |
265 | |
266 | if Self_ID.Deferral_Level = 0 | |
267 | and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level | |
268 | and then not Self_ID.Aborting | |
269 | then | |
84481f76 RK |
270 | Self_ID.Aborting := True; |
271 | ||
272 | -- Make sure signals used for RTS internal purpose are unmasked | |
273 | ||
dae22b53 AC |
274 | Result := |
275 | thr_sigsetmask | |
276 | (SIG_UNBLOCK, | |
277 | Unblocked_Signal_Mask'Unchecked_Access, | |
278 | Old_Set'Unchecked_Access); | |
84481f76 RK |
279 | pragma Assert (Result = 0); |
280 | ||
281 | raise Standard'Abort_Signal; | |
84481f76 | 282 | end if; |
84481f76 RK |
283 | end Abort_Handler; |
284 | ||
15ce9ca2 AC |
285 | ----------------- |
286 | -- Stack_Guard -- | |
287 | ----------------- | |
84481f76 RK |
288 | |
289 | -- The underlying thread system sets a guard page at the | |
290 | -- bottom of a thread stack, so nothing is needed. | |
291 | ||
b5e792e2 | 292 | procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is |
fbf5a39b AC |
293 | pragma Unreferenced (T); |
294 | pragma Unreferenced (On); | |
84481f76 RK |
295 | begin |
296 | null; | |
297 | end Stack_Guard; | |
298 | ||
15ce9ca2 AC |
299 | ------------------- |
300 | -- Get_Thread_Id -- | |
301 | ------------------- | |
84481f76 | 302 | |
b5e792e2 | 303 | function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is |
84481f76 RK |
304 | begin |
305 | return T.Common.LL.Thread; | |
306 | end Get_Thread_Id; | |
307 | ||
fbf5a39b AC |
308 | ---------------- |
309 | -- Initialize -- | |
310 | ---------------- | |
311 | ||
b5e792e2 | 312 | procedure Initialize (Environment_Task : ST.Task_Id) is |
fbf5a39b AC |
313 | act : aliased struct_sigaction; |
314 | old_act : aliased struct_sigaction; | |
315 | Tmp_Set : aliased sigset_t; | |
316 | Result : Interfaces.C.int; | |
317 | ||
318 | procedure Configure_Processors; | |
319 | -- Processors configuration | |
320 | -- The user can specify a processor which the program should run | |
321 | -- on to emulate a single-processor system. This can be easily | |
322 | -- done by setting environment variable GNAT_PROCESSOR to one of | |
323 | -- the following : | |
324 | -- | |
325 | -- -2 : use the default configuration (run the program on all | |
326 | -- available processors) - this is the same as having | |
327 | -- GNAT_PROCESSOR unset | |
328 | -- -1 : let the RTS choose one processor and run the program on | |
329 | -- that processor | |
330 | -- 0 .. Last_Proc : run the program on the specified processor | |
331 | -- | |
332 | -- Last_Proc is equal to the value of the system variable | |
333 | -- _SC_NPROCESSORS_CONF, minus one. | |
334 | ||
335 | procedure Configure_Processors is | |
dae22b53 AC |
336 | Proc_Acc : constant System.OS_Lib.String_Access := |
337 | System.OS_Lib.Getenv ("GNAT_PROCESSOR"); | |
fbf5a39b AC |
338 | Proc : aliased processorid_t; -- User processor # |
339 | Last_Proc : processorid_t; -- Last processor # | |
340 | ||
341 | begin | |
342 | if Proc_Acc.all'Length /= 0 then | |
8dbb621e | 343 | |
fbf5a39b AC |
344 | -- Environment variable is defined |
345 | ||
346 | Last_Proc := Num_Procs - 1; | |
347 | ||
348 | if Last_Proc /= -1 then | |
349 | Proc := processorid_t'Value (Proc_Acc.all); | |
350 | ||
351 | if Proc <= -2 or else Proc > Last_Proc then | |
dae22b53 | 352 | |
fbf5a39b | 353 | -- Use the default configuration |
dae22b53 | 354 | |
fbf5a39b | 355 | null; |
dae22b53 | 356 | |
fbf5a39b | 357 | elsif Proc = -1 then |
dae22b53 | 358 | |
fbf5a39b AC |
359 | -- Choose a processor |
360 | ||
361 | Result := 0; | |
fbf5a39b AC |
362 | while Proc < Last_Proc loop |
363 | Proc := Proc + 1; | |
364 | Result := p_online (Proc, PR_STATUS); | |
365 | exit when Result = PR_ONLINE; | |
366 | end loop; | |
367 | ||
368 | pragma Assert (Result = PR_ONLINE); | |
369 | Result := processor_bind (P_PID, P_MYID, Proc, null); | |
370 | pragma Assert (Result = 0); | |
371 | ||
372 | else | |
373 | -- Use user processor | |
374 | ||
375 | Result := processor_bind (P_PID, P_MYID, Proc, null); | |
376 | pragma Assert (Result = 0); | |
377 | end if; | |
378 | end if; | |
379 | end if; | |
380 | ||
381 | exception | |
382 | when Constraint_Error => | |
383 | ||
384 | -- Illegal environment variable GNAT_PROCESSOR - ignored | |
385 | ||
386 | null; | |
387 | end Configure_Processors; | |
388 | ||
0ab80019 AC |
389 | function State |
390 | (Int : System.Interrupt_Management.Interrupt_ID) return Character; | |
fbf5a39b AC |
391 | pragma Import (C, State, "__gnat_get_interrupt_state"); |
392 | -- Get interrupt state. Defined in a-init.c | |
393 | -- The input argument is the interrupt number, | |
394 | -- and the result is one of the following: | |
84481f76 | 395 | |
fbf5a39b AC |
396 | Default : constant Character := 's'; |
397 | -- 'n' this interrupt not set by any Interrupt_State pragma | |
398 | -- 'u' Interrupt_State pragma set state to User | |
399 | -- 'r' Interrupt_State pragma set state to Runtime | |
400 | -- 's' Interrupt_State pragma set state to System (use "default" | |
401 | -- system handler) | |
402 | ||
403 | -- Start of processing for Initialize | |
404 | ||
405 | begin | |
b5e792e2 | 406 | Environment_Task_Id := Environment_Task; |
fbf5a39b | 407 | |
3b91d88e AC |
408 | Interrupt_Management.Initialize; |
409 | ||
410 | -- Prepare the set of signals that should unblocked in all tasks | |
411 | ||
412 | Result := sigemptyset (Unblocked_Signal_Mask'Access); | |
413 | pragma Assert (Result = 0); | |
414 | ||
415 | for J in Interrupt_Management.Interrupt_ID loop | |
416 | if System.Interrupt_Management.Keep_Unmasked (J) then | |
417 | Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); | |
418 | pragma Assert (Result = 0); | |
419 | end if; | |
420 | end loop; | |
421 | ||
422 | if Dispatching_Policy = 'F' then | |
423 | declare | |
424 | Result : Interfaces.C.long; | |
425 | Class_Info : aliased struct_pcinfo; | |
426 | Secs, Nsecs : Interfaces.C.long; | |
427 | ||
428 | begin | |
429 | -- If a pragma Time_Slice is specified, takes the value in account | |
430 | ||
431 | if Time_Slice_Val > 0 then | |
8dbb621e | 432 | |
dae22b53 | 433 | -- Convert Time_Slice_Val (microseconds) to seconds/nanosecs |
3b91d88e | 434 | |
8dbb621e EB |
435 | Secs := Interfaces.C.long (Time_Slice_Val / 1_000_000); |
436 | Nsecs := | |
437 | Interfaces.C.long ((Time_Slice_Val rem 1_000_000) * 1_000); | |
3b91d88e AC |
438 | |
439 | -- Otherwise, default to no time slicing (i.e run until blocked) | |
440 | ||
441 | else | |
442 | Secs := RT_TQINF; | |
443 | Nsecs := RT_TQINF; | |
444 | end if; | |
445 | ||
8dbb621e | 446 | -- Get the real time class id |
3b91d88e AC |
447 | |
448 | Class_Info.pc_clname (1) := 'R'; | |
449 | Class_Info.pc_clname (2) := 'T'; | |
450 | Class_Info.pc_clname (3) := ASCII.NUL; | |
451 | ||
452 | Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_GETCID, | |
453 | Class_Info'Address); | |
454 | ||
455 | -- Request the real time class | |
456 | ||
457 | Prio_Param.pc_cid := Class_Info.pc_cid; | |
458 | Prio_Param.rt_pri := pri_t (Class_Info.rt_maxpri); | |
459 | Prio_Param.rt_tqsecs := Secs; | |
460 | Prio_Param.rt_tqnsecs := Nsecs; | |
461 | ||
dae22b53 AC |
462 | Result := |
463 | priocntl | |
464 | (PC_VERSION, P_LWPID, P_MYID, PC_SETPARMS, Prio_Param'Address); | |
3b91d88e AC |
465 | |
466 | Using_Real_Time_Class := Result /= -1; | |
467 | end; | |
468 | end if; | |
469 | ||
470 | Specific.Initialize (Environment_Task); | |
471 | ||
472 | -- The following is done in Enter_Task, but this is too late for the | |
fbf5a39b AC |
473 | -- Environment Task, since we need to call Self in Check_Locks when |
474 | -- the run time is compiled with assertions on. | |
475 | ||
3b91d88e | 476 | Specific.Set (Environment_Task); |
fbf5a39b | 477 | |
8dbb621e | 478 | -- Initialize the lock used to synchronize chain of all ATCBs |
fbf5a39b AC |
479 | |
480 | Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); | |
481 | ||
482 | Enter_Task (Environment_Task); | |
483 | ||
484 | -- Install the abort-signal handler | |
485 | ||
dae22b53 AC |
486 | if State |
487 | (System.Interrupt_Management.Abort_Task_Interrupt) /= Default | |
fbf5a39b AC |
488 | then |
489 | -- Set sa_flags to SA_NODEFER so that during the handler execution | |
490 | -- we do not change the Signal_Mask to be masked for the Abort_Signal | |
491 | -- This is a temporary fix to the problem that the Signal_Mask is | |
492 | -- not restored after the exception (longjmp) from the handler. | |
493 | -- The right fix should be made in sigsetjmp so that we save | |
494 | -- the Signal_Set and restore it after a longjmp. | |
495 | -- In that case, this field should be changed back to 0. ??? | |
496 | ||
497 | act.sa_flags := 16; | |
498 | ||
499 | act.sa_handler := Abort_Handler'Address; | |
500 | Result := sigemptyset (Tmp_Set'Access); | |
501 | pragma Assert (Result = 0); | |
502 | act.sa_mask := Tmp_Set; | |
503 | ||
504 | Result := | |
dae22b53 AC |
505 | sigaction |
506 | (Signal (System.Interrupt_Management.Abort_Task_Interrupt), | |
507 | act'Unchecked_Access, | |
508 | old_act'Unchecked_Access); | |
fbf5a39b AC |
509 | pragma Assert (Result = 0); |
510 | end if; | |
511 | ||
512 | Configure_Processors; | |
513 | end Initialize; | |
84481f76 RK |
514 | |
515 | --------------------- | |
516 | -- Initialize_Lock -- | |
517 | --------------------- | |
518 | ||
dae22b53 AC |
519 | -- Note: mutexes and cond_variables needed per-task basis are initialized |
520 | -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such | |
521 | -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any | |
12a13f01 | 522 | -- status change of RTS. Therefore raising Storage_Error in the following |
dae22b53 | 523 | -- routines should be able to be handled safely. |
84481f76 RK |
524 | |
525 | procedure Initialize_Lock | |
526 | (Prio : System.Any_Priority; | |
d90e94c7 | 527 | L : not null access Lock) |
84481f76 RK |
528 | is |
529 | Result : Interfaces.C.int; | |
530 | ||
531 | begin | |
532 | pragma Assert (Check_Initialize_Lock (Lock_Ptr (L), PO_Level)); | |
533 | ||
534 | if Priority_Ceiling_Emulation then | |
535 | L.Ceiling := Prio; | |
536 | end if; | |
537 | ||
538 | Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address); | |
539 | pragma Assert (Result = 0 or else Result = ENOMEM); | |
540 | ||
541 | if Result = ENOMEM then | |
3b91d88e | 542 | raise Storage_Error with "Failed to allocate a lock"; |
84481f76 RK |
543 | end if; |
544 | end Initialize_Lock; | |
545 | ||
546 | procedure Initialize_Lock | |
d90e94c7 | 547 | (L : not null access RTS_Lock; |
84481f76 RK |
548 | Level : Lock_Level) |
549 | is | |
550 | Result : Interfaces.C.int; | |
551 | ||
552 | begin | |
dae22b53 AC |
553 | pragma Assert |
554 | (Check_Initialize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)), Level)); | |
84481f76 RK |
555 | Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address); |
556 | pragma Assert (Result = 0 or else Result = ENOMEM); | |
557 | ||
558 | if Result = ENOMEM then | |
3b91d88e | 559 | raise Storage_Error with "Failed to allocate a lock"; |
84481f76 RK |
560 | end if; |
561 | end Initialize_Lock; | |
562 | ||
563 | ------------------- | |
564 | -- Finalize_Lock -- | |
565 | ------------------- | |
566 | ||
d90e94c7 | 567 | procedure Finalize_Lock (L : not null access Lock) is |
84481f76 | 568 | Result : Interfaces.C.int; |
84481f76 RK |
569 | begin |
570 | pragma Assert (Check_Finalize_Lock (Lock_Ptr (L))); | |
571 | Result := mutex_destroy (L.L'Access); | |
572 | pragma Assert (Result = 0); | |
573 | end Finalize_Lock; | |
574 | ||
d90e94c7 | 575 | procedure Finalize_Lock (L : not null access RTS_Lock) is |
84481f76 | 576 | Result : Interfaces.C.int; |
84481f76 RK |
577 | begin |
578 | pragma Assert (Check_Finalize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); | |
579 | Result := mutex_destroy (L.L'Access); | |
580 | pragma Assert (Result = 0); | |
581 | end Finalize_Lock; | |
582 | ||
583 | ---------------- | |
584 | -- Write_Lock -- | |
585 | ---------------- | |
586 | ||
d90e94c7 | 587 | procedure Write_Lock |
dae22b53 AC |
588 | (L : not null access Lock; |
589 | Ceiling_Violation : out Boolean) | |
d90e94c7 | 590 | is |
84481f76 RK |
591 | Result : Interfaces.C.int; |
592 | ||
593 | begin | |
594 | pragma Assert (Check_Lock (Lock_Ptr (L))); | |
595 | ||
596 | if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then | |
597 | declare | |
b5e792e2 | 598 | Self_Id : constant Task_Id := Self; |
84481f76 RK |
599 | Saved_Priority : System.Any_Priority; |
600 | ||
601 | begin | |
602 | if Self_Id.Common.LL.Active_Priority > L.Ceiling then | |
603 | Ceiling_Violation := True; | |
604 | return; | |
605 | end if; | |
606 | ||
607 | Saved_Priority := Self_Id.Common.LL.Active_Priority; | |
608 | ||
609 | if Self_Id.Common.LL.Active_Priority < L.Ceiling then | |
610 | Set_Priority (Self_Id, L.Ceiling); | |
611 | end if; | |
612 | ||
613 | Result := mutex_lock (L.L'Access); | |
614 | pragma Assert (Result = 0); | |
615 | Ceiling_Violation := False; | |
616 | ||
617 | L.Saved_Priority := Saved_Priority; | |
618 | end; | |
619 | ||
620 | else | |
621 | Result := mutex_lock (L.L'Access); | |
622 | pragma Assert (Result = 0); | |
623 | Ceiling_Violation := False; | |
624 | end if; | |
625 | ||
626 | pragma Assert (Record_Lock (Lock_Ptr (L))); | |
627 | end Write_Lock; | |
628 | ||
07fc65c4 | 629 | procedure Write_Lock |
d90e94c7 | 630 | (L : not null access RTS_Lock; |
fbf5a39b | 631 | Global_Lock : Boolean := False) |
07fc65c4 | 632 | is |
84481f76 | 633 | Result : Interfaces.C.int; |
84481f76 | 634 | begin |
07fc65c4 GB |
635 | if not Single_Lock or else Global_Lock then |
636 | pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); | |
637 | Result := mutex_lock (L.L'Access); | |
638 | pragma Assert (Result = 0); | |
639 | pragma Assert (Record_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); | |
640 | end if; | |
84481f76 RK |
641 | end Write_Lock; |
642 | ||
b5e792e2 | 643 | procedure Write_Lock (T : Task_Id) is |
84481f76 | 644 | Result : Interfaces.C.int; |
84481f76 | 645 | begin |
07fc65c4 GB |
646 | if not Single_Lock then |
647 | pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access))); | |
648 | Result := mutex_lock (T.Common.LL.L.L'Access); | |
649 | pragma Assert (Result = 0); | |
650 | pragma Assert (Record_Lock (To_Lock_Ptr (T.Common.LL.L'Access))); | |
651 | end if; | |
84481f76 RK |
652 | end Write_Lock; |
653 | ||
654 | --------------- | |
655 | -- Read_Lock -- | |
656 | --------------- | |
657 | ||
d90e94c7 | 658 | procedure Read_Lock |
dae22b53 AC |
659 | (L : not null access Lock; |
660 | Ceiling_Violation : out Boolean) is | |
84481f76 RK |
661 | begin |
662 | Write_Lock (L, Ceiling_Violation); | |
663 | end Read_Lock; | |
664 | ||
665 | ------------ | |
666 | -- Unlock -- | |
667 | ------------ | |
668 | ||
d90e94c7 | 669 | procedure Unlock (L : not null access Lock) is |
dae22b53 | 670 | Result : Interfaces.C.int; |
fbf5a39b | 671 | |
84481f76 RK |
672 | begin |
673 | pragma Assert (Check_Unlock (Lock_Ptr (L))); | |
674 | ||
675 | if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then | |
676 | declare | |
b5e792e2 | 677 | Self_Id : constant Task_Id := Self; |
84481f76 RK |
678 | |
679 | begin | |
680 | Result := mutex_unlock (L.L'Access); | |
681 | pragma Assert (Result = 0); | |
682 | ||
683 | if Self_Id.Common.LL.Active_Priority > L.Saved_Priority then | |
684 | Set_Priority (Self_Id, L.Saved_Priority); | |
685 | end if; | |
686 | end; | |
687 | else | |
688 | Result := mutex_unlock (L.L'Access); | |
689 | pragma Assert (Result = 0); | |
690 | end if; | |
691 | end Unlock; | |
692 | ||
d90e94c7 | 693 | procedure Unlock |
dae22b53 AC |
694 | (L : not null access RTS_Lock; |
695 | Global_Lock : Boolean := False) | |
d90e94c7 | 696 | is |
84481f76 | 697 | Result : Interfaces.C.int; |
84481f76 | 698 | begin |
07fc65c4 GB |
699 | if not Single_Lock or else Global_Lock then |
700 | pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); | |
701 | Result := mutex_unlock (L.L'Access); | |
702 | pragma Assert (Result = 0); | |
703 | end if; | |
84481f76 RK |
704 | end Unlock; |
705 | ||
b5e792e2 | 706 | procedure Unlock (T : Task_Id) is |
84481f76 | 707 | Result : Interfaces.C.int; |
84481f76 | 708 | begin |
07fc65c4 GB |
709 | if not Single_Lock then |
710 | pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access))); | |
711 | Result := mutex_unlock (T.Common.LL.L.L'Access); | |
712 | pragma Assert (Result = 0); | |
713 | end if; | |
84481f76 RK |
714 | end Unlock; |
715 | ||
dae22b53 AC |
716 | ----------------- |
717 | -- Set_Ceiling -- | |
718 | ----------------- | |
719 | ||
720 | -- Dynamic priority ceilings are not supported by the underlying system | |
721 | ||
722 | procedure Set_Ceiling | |
723 | (L : not null access Lock; | |
724 | Prio : System.Any_Priority) | |
725 | is | |
726 | pragma Unreferenced (L, Prio); | |
727 | begin | |
728 | null; | |
729 | end Set_Ceiling; | |
730 | ||
84481f76 RK |
731 | -- For the time delay implementation, we need to make sure we |
732 | -- achieve following criteria: | |
733 | ||
734 | -- 1) We have to delay at least for the amount requested. | |
735 | -- 2) We have to give up CPU even though the actual delay does not | |
736 | -- result in blocking. | |
737 | -- 3) Except for restricted run-time systems that do not support | |
738 | -- ATC or task abort, the delay must be interrupted by the | |
739 | -- abort_task operation. | |
740 | -- 4) The implementation has to be efficient so that the delay overhead | |
741 | -- is relatively cheap. | |
742 | -- (1)-(3) are Ada requirements. Even though (2) is an Annex-D | |
743 | -- requirement we still want to provide the effect in all cases. | |
744 | -- The reason is that users may want to use short delays to implement | |
745 | -- their own scheduling effect in the absence of language provided | |
746 | -- scheduling policies. | |
747 | ||
748 | --------------------- | |
749 | -- Monotonic_Clock -- | |
750 | --------------------- | |
751 | ||
752 | function Monotonic_Clock return Duration is | |
753 | TS : aliased timespec; | |
754 | Result : Interfaces.C.int; | |
84481f76 RK |
755 | begin |
756 | Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); | |
757 | pragma Assert (Result = 0); | |
758 | return To_Duration (TS); | |
759 | end Monotonic_Clock; | |
760 | ||
761 | ------------------- | |
762 | -- RT_Resolution -- | |
763 | ------------------- | |
764 | ||
765 | function RT_Resolution return Duration is | |
766 | begin | |
767 | return 10#1.0#E-6; | |
768 | end RT_Resolution; | |
769 | ||
770 | ----------- | |
771 | -- Yield -- | |
772 | ----------- | |
773 | ||
774 | procedure Yield (Do_Yield : Boolean := True) is | |
775 | begin | |
776 | if Do_Yield then | |
777 | System.OS_Interface.thr_yield; | |
778 | end if; | |
779 | end Yield; | |
780 | ||
fbf5a39b AC |
781 | ----------- |
782 | -- Self --- | |
783 | ----------- | |
784 | ||
b5e792e2 | 785 | function Self return Task_Id renames Specific.Self; |
fbf5a39b | 786 | |
84481f76 RK |
787 | ------------------ |
788 | -- Set_Priority -- | |
789 | ------------------ | |
790 | ||
791 | procedure Set_Priority | |
b5e792e2 | 792 | (T : Task_Id; |
fbf5a39b | 793 | Prio : System.Any_Priority; |
84481f76 RK |
794 | Loss_Of_Inheritance : Boolean := False) |
795 | is | |
fbf5a39b AC |
796 | pragma Unreferenced (Loss_Of_Inheritance); |
797 | ||
91b1417d AC |
798 | Result : Interfaces.C.int; |
799 | pragma Unreferenced (Result); | |
800 | ||
dae22b53 | 801 | Param : aliased struct_pcparms; |
84481f76 RK |
802 | |
803 | use Task_Info; | |
804 | ||
805 | begin | |
806 | T.Common.Current_Priority := Prio; | |
807 | ||
808 | if Priority_Ceiling_Emulation then | |
809 | T.Common.LL.Active_Priority := Prio; | |
810 | end if; | |
811 | ||
812 | if Using_Real_Time_Class then | |
813 | Param.pc_cid := Prio_Param.pc_cid; | |
814 | Param.rt_pri := pri_t (Prio); | |
815 | Param.rt_tqsecs := Prio_Param.rt_tqsecs; | |
816 | Param.rt_tqnsecs := Prio_Param.rt_tqnsecs; | |
817 | ||
818 | Result := Interfaces.C.int ( | |
819 | priocntl (PC_VERSION, P_LWPID, T.Common.LL.LWP, PC_SETPARMS, | |
820 | Param'Address)); | |
821 | ||
822 | else | |
823 | if T.Common.Task_Info /= null | |
824 | and then not T.Common.Task_Info.Bound_To_LWP | |
825 | then | |
826 | -- The task is not bound to a LWP, so use thr_setprio | |
827 | ||
828 | Result := | |
829 | thr_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio)); | |
830 | ||
831 | else | |
84481f76 RK |
832 | -- The task is bound to a LWP, use priocntl |
833 | -- ??? TBD | |
834 | ||
835 | null; | |
836 | end if; | |
837 | end if; | |
838 | end Set_Priority; | |
839 | ||
840 | ------------------ | |
841 | -- Get_Priority -- | |
842 | ------------------ | |
843 | ||
b5e792e2 | 844 | function Get_Priority (T : Task_Id) return System.Any_Priority is |
84481f76 RK |
845 | begin |
846 | return T.Common.Current_Priority; | |
847 | end Get_Priority; | |
848 | ||
849 | ---------------- | |
850 | -- Enter_Task -- | |
851 | ---------------- | |
852 | ||
b5e792e2 | 853 | procedure Enter_Task (Self_ID : Task_Id) is |
84481f76 RK |
854 | Result : Interfaces.C.int; |
855 | Proc : processorid_t; -- User processor # | |
856 | Last_Proc : processorid_t; -- Last processor # | |
857 | ||
858 | use System.Task_Info; | |
859 | begin | |
860 | Self_ID.Common.LL.Thread := thr_self; | |
861 | ||
862 | Self_ID.Common.LL.LWP := lwp_self; | |
863 | ||
864 | if Self_ID.Common.Task_Info /= null then | |
865 | if Self_ID.Common.Task_Info.New_LWP | |
866 | and then Self_ID.Common.Task_Info.CPU /= CPU_UNCHANGED | |
867 | then | |
868 | Last_Proc := Num_Procs - 1; | |
869 | ||
870 | if Self_ID.Common.Task_Info.CPU = ANY_CPU then | |
871 | Result := 0; | |
872 | Proc := 0; | |
84481f76 RK |
873 | while Proc < Last_Proc loop |
874 | Result := p_online (Proc, PR_STATUS); | |
875 | exit when Result = PR_ONLINE; | |
876 | Proc := Proc + 1; | |
877 | end loop; | |
878 | ||
879 | Result := processor_bind (P_LWPID, P_MYID, Proc, null); | |
880 | pragma Assert (Result = 0); | |
881 | ||
882 | else | |
883 | -- Use specified processor | |
884 | ||
885 | if Self_ID.Common.Task_Info.CPU < 0 | |
886 | or else Self_ID.Common.Task_Info.CPU > Last_Proc | |
887 | then | |
888 | raise Invalid_CPU_Number; | |
889 | end if; | |
890 | ||
dae22b53 AC |
891 | Result := |
892 | processor_bind | |
893 | (P_LWPID, P_MYID, Self_ID.Common.Task_Info.CPU, null); | |
84481f76 RK |
894 | pragma Assert (Result = 0); |
895 | end if; | |
896 | end if; | |
897 | end if; | |
898 | ||
fbf5a39b | 899 | Specific.Set (Self_ID); |
84481f76 | 900 | |
b5e792e2 | 901 | -- We need the above code even if we do direct fetch of Task_Id in Self |
84481f76 RK |
902 | -- for the main task on Sun, x86 Solaris and for gcc 2.7.2. |
903 | ||
07fc65c4 | 904 | Lock_RTS; |
84481f76 | 905 | |
07fc65c4 GB |
906 | for J in Known_Tasks'Range loop |
907 | if Known_Tasks (J) = null then | |
908 | Known_Tasks (J) := Self_ID; | |
909 | Self_ID.Known_Tasks_Index := J; | |
84481f76 RK |
910 | exit; |
911 | end if; | |
912 | end loop; | |
07fc65c4 GB |
913 | |
914 | Unlock_RTS; | |
84481f76 RK |
915 | end Enter_Task; |
916 | ||
917 | -------------- | |
918 | -- New_ATCB -- | |
919 | -------------- | |
920 | ||
b5e792e2 | 921 | function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is |
84481f76 RK |
922 | begin |
923 | return new Ada_Task_Control_Block (Entry_Num); | |
924 | end New_ATCB; | |
925 | ||
fbf5a39b AC |
926 | ------------------- |
927 | -- Is_Valid_Task -- | |
928 | ------------------- | |
929 | ||
930 | function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; | |
931 | ||
932 | ----------------------------- | |
933 | -- Register_Foreign_Thread -- | |
934 | ----------------------------- | |
935 | ||
b5e792e2 | 936 | function Register_Foreign_Thread return Task_Id is |
fbf5a39b AC |
937 | begin |
938 | if Is_Valid_Task then | |
939 | return Self; | |
940 | else | |
941 | return Register_Foreign_Thread (thr_self); | |
942 | end if; | |
943 | end Register_Foreign_Thread; | |
944 | ||
07fc65c4 GB |
945 | -------------------- |
946 | -- Initialize_TCB -- | |
947 | -------------------- | |
84481f76 | 948 | |
b5e792e2 | 949 | procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is |
07fc65c4 | 950 | Result : Interfaces.C.int := 0; |
fbf5a39b | 951 | |
84481f76 | 952 | begin |
8dbb621e | 953 | -- Give the task a unique serial number |
84481f76 RK |
954 | |
955 | Self_ID.Serial_Number := Next_Serial_Number; | |
956 | Next_Serial_Number := Next_Serial_Number + 1; | |
957 | pragma Assert (Next_Serial_Number /= 0); | |
958 | ||
959 | Self_ID.Common.LL.Thread := To_thread_t (-1); | |
07fc65c4 GB |
960 | |
961 | if not Single_Lock then | |
dae22b53 AC |
962 | Result := |
963 | mutex_init | |
964 | (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address); | |
07fc65c4 GB |
965 | Self_ID.Common.LL.L.Level := |
966 | Private_Task_Serial_Number (Self_ID.Serial_Number); | |
967 | pragma Assert (Result = 0 or else Result = ENOMEM); | |
968 | end if; | |
84481f76 RK |
969 | |
970 | if Result = 0 then | |
971 | Result := cond_init (Self_ID.Common.LL.CV'Access, USYNC_THREAD, 0); | |
972 | pragma Assert (Result = 0 or else Result = ENOMEM); | |
07fc65c4 | 973 | end if; |
84481f76 | 974 | |
07fc65c4 GB |
975 | if Result = 0 then |
976 | Succeeded := True; | |
977 | else | |
978 | if not Single_Lock then | |
84481f76 RK |
979 | Result := mutex_destroy (Self_ID.Common.LL.L.L'Access); |
980 | pragma Assert (Result = 0); | |
84481f76 RK |
981 | end if; |
982 | ||
84481f76 RK |
983 | Succeeded := False; |
984 | end if; | |
985 | end Initialize_TCB; | |
986 | ||
987 | ----------------- | |
988 | -- Create_Task -- | |
989 | ----------------- | |
990 | ||
991 | procedure Create_Task | |
b5e792e2 | 992 | (T : Task_Id; |
84481f76 RK |
993 | Wrapper : System.Address; |
994 | Stack_Size : System.Parameters.Size_Type; | |
995 | Priority : System.Any_Priority; | |
996 | Succeeded : out Boolean) | |
997 | is | |
fbf5a39b AC |
998 | pragma Unreferenced (Priority); |
999 | ||
57d8e34e | 1000 | Result : Interfaces.C.int; |
84481f76 | 1001 | Adjusted_Stack_Size : Interfaces.C.size_t; |
57d8e34e | 1002 | Opts : Interfaces.C.int := THR_DETACHED; |
84481f76 | 1003 | |
57d8e34e | 1004 | Page_Size : constant System.Parameters.Size_Type := 4096; |
84481f76 RK |
1005 | -- This constant is for reserving extra space at the |
1006 | -- end of the stack, which can be used by the stack | |
1007 | -- checking as guard page. The idea is that we need | |
1008 | -- to have at least Stack_Size bytes available for | |
1009 | -- actual use. | |
1010 | ||
1011 | use System.Task_Info; | |
fbf5a39b | 1012 | |
84481f76 | 1013 | begin |
57d8e34e | 1014 | Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size + Page_Size); |
84481f76 RK |
1015 | |
1016 | -- Since the initial signal mask of a thread is inherited from the | |
1017 | -- creator, and the Environment task has all its signals masked, we | |
1018 | -- do not need to manipulate caller's signal mask at this point. | |
1019 | -- All tasks in RTS will have All_Tasks_Mask initially. | |
1020 | ||
1021 | if T.Common.Task_Info /= null then | |
84481f76 RK |
1022 | if T.Common.Task_Info.New_LWP then |
1023 | Opts := Opts + THR_NEW_LWP; | |
1024 | end if; | |
1025 | ||
1026 | if T.Common.Task_Info.Bound_To_LWP then | |
1027 | Opts := Opts + THR_BOUND; | |
1028 | end if; | |
1029 | ||
1030 | else | |
1031 | Opts := THR_DETACHED + THR_BOUND; | |
1032 | end if; | |
1033 | ||
dae22b53 AC |
1034 | Result := |
1035 | thr_create | |
1036 | (System.Null_Address, | |
1037 | Adjusted_Stack_Size, | |
1038 | Thread_Body_Access (Wrapper), | |
1039 | To_Address (T), | |
1040 | Opts, | |
1041 | T.Common.LL.Thread'Access); | |
84481f76 RK |
1042 | |
1043 | Succeeded := Result = 0; | |
1044 | pragma Assert | |
1045 | (Result = 0 | |
1046 | or else Result = ENOMEM | |
1047 | or else Result = EAGAIN); | |
1048 | end Create_Task; | |
1049 | ||
1050 | ------------------ | |
1051 | -- Finalize_TCB -- | |
1052 | ------------------ | |
1053 | ||
b5e792e2 | 1054 | procedure Finalize_TCB (T : Task_Id) is |
dae22b53 AC |
1055 | Result : Interfaces.C.int; |
1056 | Tmp : Task_Id := T; | |
fbf5a39b | 1057 | Is_Self : constant Boolean := T = Self; |
84481f76 RK |
1058 | |
1059 | procedure Free is new | |
dae22b53 | 1060 | Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); |
84481f76 RK |
1061 | |
1062 | begin | |
1063 | T.Common.LL.Thread := To_thread_t (0); | |
07fc65c4 GB |
1064 | |
1065 | if not Single_Lock then | |
1066 | Result := mutex_destroy (T.Common.LL.L.L'Access); | |
1067 | pragma Assert (Result = 0); | |
1068 | end if; | |
1069 | ||
84481f76 RK |
1070 | Result := cond_destroy (T.Common.LL.CV'Access); |
1071 | pragma Assert (Result = 0); | |
1072 | ||
1073 | if T.Known_Tasks_Index /= -1 then | |
1074 | Known_Tasks (T.Known_Tasks_Index) := null; | |
1075 | end if; | |
1076 | ||
1077 | Free (Tmp); | |
fbf5a39b AC |
1078 | |
1079 | if Is_Self then | |
1080 | Specific.Set (null); | |
1081 | end if; | |
84481f76 RK |
1082 | end Finalize_TCB; |
1083 | ||
1084 | --------------- | |
1085 | -- Exit_Task -- | |
1086 | --------------- | |
1087 | ||
dae22b53 AC |
1088 | -- This procedure must be called with abort deferred. It can no longer |
1089 | -- call Self or access the current task's ATCB, since the ATCB has been | |
1090 | -- deallocated. | |
84481f76 RK |
1091 | |
1092 | procedure Exit_Task is | |
1093 | begin | |
fbf5a39b | 1094 | Specific.Set (null); |
84481f76 RK |
1095 | end Exit_Task; |
1096 | ||
1097 | ---------------- | |
1098 | -- Abort_Task -- | |
1099 | ---------------- | |
1100 | ||
b5e792e2 | 1101 | procedure Abort_Task (T : Task_Id) is |
84481f76 RK |
1102 | Result : Interfaces.C.int; |
1103 | begin | |
1104 | pragma Assert (T /= Self); | |
dae22b53 AC |
1105 | Result := |
1106 | thr_kill | |
1107 | (T.Common.LL.Thread, | |
1108 | Signal (System.Interrupt_Management.Abort_Task_Interrupt)); | |
84481f76 RK |
1109 | pragma Assert (Result = 0); |
1110 | end Abort_Task; | |
1111 | ||
07fc65c4 GB |
1112 | ----------- |
1113 | -- Sleep -- | |
1114 | ----------- | |
84481f76 RK |
1115 | |
1116 | procedure Sleep | |
b5e792e2 | 1117 | (Self_ID : Task_Id; |
84481f76 RK |
1118 | Reason : Task_States) |
1119 | is | |
1120 | Result : Interfaces.C.int; | |
fbf5a39b | 1121 | |
84481f76 RK |
1122 | begin |
1123 | pragma Assert (Check_Sleep (Reason)); | |
1124 | ||
07fc65c4 | 1125 | if Single_Lock then |
dae22b53 AC |
1126 | Result := |
1127 | cond_wait | |
1128 | (Self_ID.Common.LL.CV'Access, Single_RTS_Lock.L'Access); | |
07fc65c4 | 1129 | else |
dae22b53 AC |
1130 | Result := |
1131 | cond_wait | |
1132 | (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access); | |
07fc65c4 GB |
1133 | end if; |
1134 | ||
dae22b53 AC |
1135 | pragma Assert |
1136 | (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason)); | |
07fc65c4 | 1137 | pragma Assert (Result = 0 or else Result = EINTR); |
84481f76 RK |
1138 | end Sleep; |
1139 | ||
12a13f01 RW |
1140 | -- Note that we are relying heavily here on GNAT representing |
1141 | -- Calendar.Time, System.Real_Time.Time, Duration, | |
1142 | -- System.Real_Time.Time_Span in the same way, i.e., as a 64-bit count of | |
1143 | -- nanoseconds. | |
84481f76 | 1144 | |
12a13f01 | 1145 | -- This allows us to always pass the timeout value as a Duration. |
84481f76 RK |
1146 | |
1147 | -- ??? | |
8dbb621e EB |
1148 | -- We are taking liberties here with the semantics of the delays. That is, |
1149 | -- we make no distinction between delays on the Calendar clock and delays | |
1150 | -- on the Real_Time clock. That is technically incorrect, if the Calendar | |
1151 | -- clock happens to be reset or adjusted. To solve this defect will require | |
1152 | -- modification to the compiler interface, so that it can pass through more | |
1153 | -- information, to tell us here which clock to use! | |
84481f76 RK |
1154 | |
1155 | -- cond_timedwait will return if any of the following happens: | |
1156 | -- 1) some other task did cond_signal on this condition variable | |
1157 | -- In this case, the return value is 0 | |
1158 | -- 2) the call just returned, for no good reason | |
1159 | -- This is called a "spurious wakeup". | |
1160 | -- In this case, the return value may also be 0. | |
1161 | -- 3) the time delay expires | |
1162 | -- In this case, the return value is ETIME | |
1163 | -- 4) this task received a signal, which was handled by some | |
1164 | -- handler procedure, and now the thread is resuming execution | |
1165 | -- UNIX calls this an "interrupted" system call. | |
1166 | -- In this case, the return value is EINTR | |
1167 | ||
8dbb621e EB |
1168 | -- If the cond_timedwait returns 0 or EINTR, it is still possible that the |
1169 | -- time has actually expired, and by chance a signal or cond_signal | |
1170 | -- occurred at around the same time. | |
1171 | ||
1172 | -- We have also observed that on some OS's the value ETIME will be | |
1173 | -- returned, but the clock will show that the full delay has not yet | |
1174 | -- expired. | |
1175 | ||
1176 | -- For these reasons, we need to check the clock after return from | |
1177 | -- cond_timedwait. If the time has expired, we will set Timedout = True. | |
1178 | ||
1179 | -- This check might be omitted for systems on which the cond_timedwait() | |
1180 | -- never returns early or wakes up spuriously. | |
1181 | ||
1182 | -- Annex D requires that completion of a delay cause the task to go to the | |
1183 | -- end of its priority queue, regardless of whether the task actually was | |
1184 | -- suspended by the delay. Since cond_timedwait does not do this on | |
1185 | -- Solaris, we add a call to thr_yield at the end. We might do this at the | |
1186 | -- beginning, instead, but then the round-robin effect would not be the | |
1187 | -- same; the delayed task would be ahead of other tasks of the same | |
1188 | -- priority that awoke while it was sleeping. | |
1189 | ||
1190 | -- For Timed_Sleep, we are expecting possible cond_signals to indicate | |
1191 | -- other events (e.g., completion of a RV or completion of the abortable | |
1192 | -- part of an async. select), we want to always return if interrupted. The | |
1193 | -- caller will be responsible for checking the task state to see whether | |
1194 | -- the wakeup was spurious, and to go back to sleep again in that case. We | |
1195 | -- don't need to check for pending abort or priority change on the way in | |
1196 | -- our out; that is the caller's responsibility. | |
1197 | ||
1198 | -- For Timed_Delay, we are not expecting any cond_signals or other | |
1199 | -- interruptions, except for priority changes and aborts. Therefore, we | |
1200 | -- don't want to return unless the delay has actually expired, or the call | |
1201 | -- has been aborted. In this case, since we want to implement the entire | |
1202 | -- delay statement semantics, we do need to check for pending abort and | |
1203 | -- priority changes. We can quietly handle priority changes inside the | |
84481f76 RK |
1204 | -- procedure, since there is no entry-queue reordering involved. |
1205 | ||
1206 | ----------------- | |
1207 | -- Timed_Sleep -- | |
1208 | ----------------- | |
1209 | ||
84481f76 | 1210 | procedure Timed_Sleep |
b5e792e2 | 1211 | (Self_ID : Task_Id; |
84481f76 RK |
1212 | Time : Duration; |
1213 | Mode : ST.Delay_Modes; | |
1214 | Reason : System.Tasking.Task_States; | |
1215 | Timedout : out Boolean; | |
1216 | Yielded : out Boolean) | |
1217 | is | |
dae22b53 AC |
1218 | Base_Time : constant Duration := Monotonic_Clock; |
1219 | Check_Time : Duration := Base_Time; | |
84481f76 RK |
1220 | Abs_Time : Duration; |
1221 | Request : aliased timespec; | |
1222 | Result : Interfaces.C.int; | |
1223 | ||
1224 | begin | |
1225 | pragma Assert (Check_Sleep (Reason)); | |
1226 | Timedout := True; | |
1227 | Yielded := False; | |
1228 | ||
1229 | if Mode = Relative then | |
1230 | Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; | |
1231 | else | |
1232 | Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); | |
1233 | end if; | |
1234 | ||
1235 | if Abs_Time > Check_Time then | |
1236 | Request := To_Timespec (Abs_Time); | |
1237 | ||
1238 | loop | |
dae22b53 | 1239 | exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; |
84481f76 | 1240 | |
07fc65c4 | 1241 | if Single_Lock then |
dae22b53 AC |
1242 | Result := |
1243 | cond_timedwait | |
1244 | (Self_ID.Common.LL.CV'Access, | |
1245 | Single_RTS_Lock.L'Access, Request'Access); | |
07fc65c4 | 1246 | else |
dae22b53 AC |
1247 | Result := |
1248 | cond_timedwait | |
1249 | (Self_ID.Common.LL.CV'Access, | |
1250 | Self_ID.Common.LL.L.L'Access, Request'Access); | |
07fc65c4 GB |
1251 | end if; |
1252 | ||
1253 | Yielded := True; | |
84481f76 | 1254 | |
dae22b53 AC |
1255 | Check_Time := Monotonic_Clock; |
1256 | exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; | |
84481f76 RK |
1257 | |
1258 | if Result = 0 or Result = EINTR then | |
fbf5a39b AC |
1259 | |
1260 | -- Somebody may have called Wakeup for us | |
1261 | ||
84481f76 RK |
1262 | Timedout := False; |
1263 | exit; | |
1264 | end if; | |
1265 | ||
1266 | pragma Assert (Result = ETIME); | |
1267 | end loop; | |
1268 | end if; | |
1269 | ||
dae22b53 AC |
1270 | pragma Assert |
1271 | (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason)); | |
84481f76 RK |
1272 | end Timed_Sleep; |
1273 | ||
1274 | ----------------- | |
1275 | -- Timed_Delay -- | |
1276 | ----------------- | |
1277 | ||
84481f76 | 1278 | procedure Timed_Delay |
8dbb621e EB |
1279 | (Self_ID : Task_Id; |
1280 | Time : Duration; | |
1281 | Mode : ST.Delay_Modes) | |
84481f76 | 1282 | is |
dae22b53 AC |
1283 | Base_Time : constant Duration := Monotonic_Clock; |
1284 | Check_Time : Duration := Base_Time; | |
84481f76 RK |
1285 | Abs_Time : Duration; |
1286 | Request : aliased timespec; | |
1287 | Result : Interfaces.C.int; | |
07fc65c4 | 1288 | Yielded : Boolean := False; |
84481f76 RK |
1289 | |
1290 | begin | |
07fc65c4 GB |
1291 | if Single_Lock then |
1292 | Lock_RTS; | |
1293 | end if; | |
1294 | ||
84481f76 RK |
1295 | Write_Lock (Self_ID); |
1296 | ||
1297 | if Mode = Relative then | |
1298 | Abs_Time := Time + Check_Time; | |
1299 | else | |
1300 | Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); | |
1301 | end if; | |
1302 | ||
1303 | if Abs_Time > Check_Time then | |
1304 | Request := To_Timespec (Abs_Time); | |
1305 | Self_ID.Common.State := Delay_Sleep; | |
1306 | ||
1307 | pragma Assert (Check_Sleep (Delay_Sleep)); | |
1308 | ||
1309 | loop | |
84481f76 RK |
1310 | exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; |
1311 | ||
07fc65c4 | 1312 | if Single_Lock then |
dae22b53 AC |
1313 | Result := |
1314 | cond_timedwait | |
1315 | (Self_ID.Common.LL.CV'Access, | |
1316 | Single_RTS_Lock.L'Access, | |
1317 | Request'Access); | |
07fc65c4 | 1318 | else |
dae22b53 AC |
1319 | Result := |
1320 | cond_timedwait | |
1321 | (Self_ID.Common.LL.CV'Access, | |
1322 | Self_ID.Common.LL.L.L'Access, | |
1323 | Request'Access); | |
07fc65c4 GB |
1324 | end if; |
1325 | ||
1326 | Yielded := True; | |
84481f76 | 1327 | |
dae22b53 AC |
1328 | Check_Time := Monotonic_Clock; |
1329 | exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; | |
84481f76 | 1330 | |
dae22b53 AC |
1331 | pragma Assert |
1332 | (Result = 0 or else | |
1333 | Result = ETIME or else | |
1334 | Result = EINTR); | |
84481f76 RK |
1335 | end loop; |
1336 | ||
dae22b53 AC |
1337 | pragma Assert |
1338 | (Record_Wakeup | |
1339 | (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Delay_Sleep)); | |
84481f76 RK |
1340 | |
1341 | Self_ID.Common.State := Runnable; | |
1342 | end if; | |
1343 | ||
1344 | Unlock (Self_ID); | |
07fc65c4 GB |
1345 | |
1346 | if Single_Lock then | |
1347 | Unlock_RTS; | |
1348 | end if; | |
1349 | ||
1350 | if not Yielded then | |
1351 | thr_yield; | |
1352 | end if; | |
84481f76 RK |
1353 | end Timed_Delay; |
1354 | ||
1355 | ------------ | |
1356 | -- Wakeup -- | |
1357 | ------------ | |
1358 | ||
1359 | procedure Wakeup | |
b5e792e2 | 1360 | (T : Task_Id; |
84481f76 RK |
1361 | Reason : Task_States) |
1362 | is | |
1363 | Result : Interfaces.C.int; | |
84481f76 RK |
1364 | begin |
1365 | pragma Assert (Check_Wakeup (T, Reason)); | |
1366 | Result := cond_signal (T.Common.LL.CV'Access); | |
1367 | pragma Assert (Result = 0); | |
1368 | end Wakeup; | |
1369 | ||
1370 | --------------------------- | |
1371 | -- Check_Initialize_Lock -- | |
1372 | --------------------------- | |
1373 | ||
dae22b53 AC |
1374 | -- The following code is intended to check some of the invariant assertions |
1375 | -- related to lock usage, on which we depend. | |
84481f76 RK |
1376 | |
1377 | function Check_Initialize_Lock | |
1378 | (L : Lock_Ptr; | |
8a6a52dc | 1379 | Level : Lock_Level) return Boolean |
84481f76 | 1380 | is |
b5e792e2 | 1381 | Self_ID : constant Task_Id := Self; |
84481f76 RK |
1382 | |
1383 | begin | |
1384 | -- Check that caller is abort-deferred | |
1385 | ||
f02b8bb8 | 1386 | if Self_ID.Deferral_Level = 0 then |
84481f76 RK |
1387 | return False; |
1388 | end if; | |
1389 | ||
1390 | -- Check that the lock is not yet initialized | |
1391 | ||
1392 | if L.Level /= 0 then | |
1393 | return False; | |
1394 | end if; | |
1395 | ||
1396 | L.Level := Lock_Level'Pos (Level) + 1; | |
1397 | return True; | |
1398 | end Check_Initialize_Lock; | |
1399 | ||
1400 | ---------------- | |
1401 | -- Check_Lock -- | |
1402 | ---------------- | |
1403 | ||
1404 | function Check_Lock (L : Lock_Ptr) return Boolean is | |
b5e792e2 | 1405 | Self_ID : constant Task_Id := Self; |
84481f76 RK |
1406 | P : Lock_Ptr; |
1407 | ||
1408 | begin | |
1409 | -- Check that the argument is not null | |
1410 | ||
1411 | if L = null then | |
1412 | return False; | |
1413 | end if; | |
1414 | ||
1415 | -- Check that L is not frozen | |
1416 | ||
1417 | if L.Frozen then | |
1418 | return False; | |
1419 | end if; | |
1420 | ||
1421 | -- Check that caller is abort-deferred | |
1422 | ||
f02b8bb8 | 1423 | if Self_ID.Deferral_Level = 0 then |
84481f76 RK |
1424 | return False; |
1425 | end if; | |
1426 | ||
1427 | -- Check that caller is not holding this lock already | |
1428 | ||
8a6a52dc | 1429 | if L.Owner = To_Owner_ID (To_Address (Self_ID)) then |
84481f76 RK |
1430 | return False; |
1431 | end if; | |
1432 | ||
07fc65c4 GB |
1433 | if Single_Lock then |
1434 | return True; | |
1435 | end if; | |
1436 | ||
84481f76 RK |
1437 | -- Check that TCB lock order rules are satisfied |
1438 | ||
1439 | P := Self_ID.Common.LL.Locks; | |
1440 | if P /= null then | |
1441 | if P.Level >= L.Level | |
1442 | and then (P.Level > 2 or else L.Level > 2) | |
1443 | then | |
1444 | return False; | |
1445 | end if; | |
1446 | end if; | |
1447 | ||
1448 | return True; | |
1449 | end Check_Lock; | |
1450 | ||
1451 | ----------------- | |
1452 | -- Record_Lock -- | |
1453 | ----------------- | |
1454 | ||
1455 | function Record_Lock (L : Lock_Ptr) return Boolean is | |
b5e792e2 | 1456 | Self_ID : constant Task_Id := Self; |
84481f76 RK |
1457 | P : Lock_Ptr; |
1458 | ||
1459 | begin | |
1460 | Lock_Count := Lock_Count + 1; | |
1461 | ||
1462 | -- There should be no owner for this lock at this point | |
1463 | ||
1464 | if L.Owner /= null then | |
1465 | return False; | |
1466 | end if; | |
1467 | ||
1468 | -- Record new owner | |
1469 | ||
8a6a52dc | 1470 | L.Owner := To_Owner_ID (To_Address (Self_ID)); |
84481f76 | 1471 | |
07fc65c4 GB |
1472 | if Single_Lock then |
1473 | return True; | |
1474 | end if; | |
1475 | ||
84481f76 RK |
1476 | -- Check that TCB lock order rules are satisfied |
1477 | ||
1478 | P := Self_ID.Common.LL.Locks; | |
1479 | ||
1480 | if P /= null then | |
1481 | L.Next := P; | |
1482 | end if; | |
1483 | ||
1484 | Self_ID.Common.LL.Locking := null; | |
1485 | Self_ID.Common.LL.Locks := L; | |
1486 | return True; | |
1487 | end Record_Lock; | |
1488 | ||
1489 | ----------------- | |
1490 | -- Check_Sleep -- | |
1491 | ----------------- | |
1492 | ||
1493 | function Check_Sleep (Reason : Task_States) return Boolean is | |
fbf5a39b AC |
1494 | pragma Unreferenced (Reason); |
1495 | ||
b5e792e2 | 1496 | Self_ID : constant Task_Id := Self; |
84481f76 RK |
1497 | P : Lock_Ptr; |
1498 | ||
1499 | begin | |
1500 | -- Check that caller is abort-deferred | |
1501 | ||
f02b8bb8 | 1502 | if Self_ID.Deferral_Level = 0 then |
84481f76 RK |
1503 | return False; |
1504 | end if; | |
1505 | ||
07fc65c4 GB |
1506 | if Single_Lock then |
1507 | return True; | |
1508 | end if; | |
1509 | ||
84481f76 RK |
1510 | -- Check that caller is holding own lock, on top of list |
1511 | ||
1512 | if Self_ID.Common.LL.Locks /= | |
1513 | To_Lock_Ptr (Self_ID.Common.LL.L'Access) | |
1514 | then | |
1515 | return False; | |
1516 | end if; | |
1517 | ||
1518 | -- Check that TCB lock order rules are satisfied | |
1519 | ||
1520 | if Self_ID.Common.LL.Locks.Next /= null then | |
1521 | return False; | |
1522 | end if; | |
1523 | ||
1524 | Self_ID.Common.LL.L.Owner := null; | |
1525 | P := Self_ID.Common.LL.Locks; | |
1526 | Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next; | |
1527 | P.Next := null; | |
1528 | return True; | |
1529 | end Check_Sleep; | |
1530 | ||
1531 | ------------------- | |
1532 | -- Record_Wakeup -- | |
1533 | ------------------- | |
1534 | ||
1535 | function Record_Wakeup | |
1536 | (L : Lock_Ptr; | |
8a6a52dc | 1537 | Reason : Task_States) return Boolean |
84481f76 | 1538 | is |
fbf5a39b AC |
1539 | pragma Unreferenced (Reason); |
1540 | ||
b5e792e2 | 1541 | Self_ID : constant Task_Id := Self; |
84481f76 RK |
1542 | P : Lock_Ptr; |
1543 | ||
1544 | begin | |
1545 | -- Record new owner | |
1546 | ||
8a6a52dc | 1547 | L.Owner := To_Owner_ID (To_Address (Self_ID)); |
84481f76 | 1548 | |
07fc65c4 GB |
1549 | if Single_Lock then |
1550 | return True; | |
1551 | end if; | |
1552 | ||
84481f76 RK |
1553 | -- Check that TCB lock order rules are satisfied |
1554 | ||
1555 | P := Self_ID.Common.LL.Locks; | |
1556 | ||
1557 | if P /= null then | |
1558 | L.Next := P; | |
1559 | end if; | |
1560 | ||
1561 | Self_ID.Common.LL.Locking := null; | |
1562 | Self_ID.Common.LL.Locks := L; | |
1563 | return True; | |
1564 | end Record_Wakeup; | |
1565 | ||
1566 | ------------------ | |
1567 | -- Check_Wakeup -- | |
1568 | ------------------ | |
1569 | ||
1570 | function Check_Wakeup | |
b5e792e2 | 1571 | (T : Task_Id; |
8a6a52dc | 1572 | Reason : Task_States) return Boolean |
84481f76 | 1573 | is |
b5e792e2 | 1574 | Self_ID : constant Task_Id := Self; |
84481f76 RK |
1575 | |
1576 | begin | |
1577 | -- Is caller holding T's lock? | |
1578 | ||
8a6a52dc | 1579 | if T.Common.LL.L.Owner /= To_Owner_ID (To_Address (Self_ID)) then |
84481f76 RK |
1580 | return False; |
1581 | end if; | |
1582 | ||
1583 | -- Are reasons for wakeup and sleep consistent? | |
1584 | ||
1585 | if T.Common.State /= Reason then | |
1586 | return False; | |
1587 | end if; | |
1588 | ||
1589 | return True; | |
1590 | end Check_Wakeup; | |
1591 | ||
1592 | ------------------ | |
1593 | -- Check_Unlock -- | |
1594 | ------------------ | |
1595 | ||
1596 | function Check_Unlock (L : Lock_Ptr) return Boolean is | |
b5e792e2 | 1597 | Self_ID : constant Task_Id := Self; |
84481f76 RK |
1598 | P : Lock_Ptr; |
1599 | ||
1600 | begin | |
1601 | Unlock_Count := Unlock_Count + 1; | |
1602 | ||
1603 | if L = null then | |
1604 | return False; | |
1605 | end if; | |
1606 | ||
1607 | if L.Buddy /= null then | |
1608 | return False; | |
1609 | end if; | |
1610 | ||
dae22b53 AC |
1611 | -- Magic constant 4??? |
1612 | ||
84481f76 RK |
1613 | if L.Level = 4 then |
1614 | Check_Count := Unlock_Count; | |
1615 | end if; | |
1616 | ||
dae22b53 AC |
1617 | -- Magic constant 1000??? |
1618 | ||
84481f76 RK |
1619 | if Unlock_Count - Check_Count > 1000 then |
1620 | Check_Count := Unlock_Count; | |
84481f76 RK |
1621 | end if; |
1622 | ||
1623 | -- Check that caller is abort-deferred | |
1624 | ||
f02b8bb8 | 1625 | if Self_ID.Deferral_Level = 0 then |
84481f76 RK |
1626 | return False; |
1627 | end if; | |
1628 | ||
1629 | -- Check that caller is holding this lock, on top of list | |
1630 | ||
1631 | if Self_ID.Common.LL.Locks /= L then | |
1632 | return False; | |
1633 | end if; | |
1634 | ||
1635 | -- Record there is no owner now | |
1636 | ||
1637 | L.Owner := null; | |
1638 | P := Self_ID.Common.LL.Locks; | |
1639 | Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next; | |
1640 | P.Next := null; | |
1641 | return True; | |
1642 | end Check_Unlock; | |
1643 | ||
1644 | -------------------- | |
1645 | -- Check_Finalize -- | |
1646 | -------------------- | |
1647 | ||
1648 | function Check_Finalize_Lock (L : Lock_Ptr) return Boolean is | |
b5e792e2 | 1649 | Self_ID : constant Task_Id := Self; |
fbf5a39b | 1650 | |
84481f76 RK |
1651 | begin |
1652 | -- Check that caller is abort-deferred | |
1653 | ||
f02b8bb8 | 1654 | if Self_ID.Deferral_Level = 0 then |
84481f76 RK |
1655 | return False; |
1656 | end if; | |
1657 | ||
1658 | -- Check that no one is holding this lock | |
1659 | ||
1660 | if L.Owner /= null then | |
1661 | return False; | |
1662 | end if; | |
1663 | ||
1664 | L.Frozen := True; | |
1665 | return True; | |
1666 | end Check_Finalize_Lock; | |
1667 | ||
b497b460 JR |
1668 | ---------------- |
1669 | -- Initialize -- | |
1670 | ---------------- | |
1671 | ||
1672 | procedure Initialize (S : in out Suspension_Object) is | |
1673 | Result : Interfaces.C.int; | |
dae22b53 | 1674 | |
b497b460 | 1675 | begin |
dae22b53 | 1676 | -- Initialize internal state (always to zero (RM D.10(6))) |
b497b460 JR |
1677 | |
1678 | S.State := False; | |
1679 | S.Waiting := False; | |
1680 | ||
1681 | -- Initialize internal mutex | |
1682 | ||
1683 | Result := mutex_init (S.L'Access, USYNC_THREAD, System.Null_Address); | |
1684 | pragma Assert (Result = 0 or else Result = ENOMEM); | |
1685 | ||
1686 | if Result = ENOMEM then | |
3b91d88e | 1687 | raise Storage_Error with "Failed to allocate a lock"; |
b497b460 JR |
1688 | end if; |
1689 | ||
1690 | -- Initialize internal condition variable | |
1691 | ||
1692 | Result := cond_init (S.CV'Access, USYNC_THREAD, 0); | |
1693 | pragma Assert (Result = 0 or else Result = ENOMEM); | |
1694 | ||
1695 | if Result /= 0 then | |
1696 | Result := mutex_destroy (S.L'Access); | |
1697 | pragma Assert (Result = 0); | |
1698 | ||
1699 | if Result = ENOMEM then | |
1700 | raise Storage_Error; | |
1701 | end if; | |
1702 | end if; | |
1703 | end Initialize; | |
1704 | ||
1705 | -------------- | |
1706 | -- Finalize -- | |
1707 | -------------- | |
1708 | ||
1709 | procedure Finalize (S : in out Suspension_Object) is | |
1710 | Result : Interfaces.C.int; | |
dae22b53 | 1711 | |
b497b460 JR |
1712 | begin |
1713 | -- Destroy internal mutex | |
1714 | ||
1715 | Result := mutex_destroy (S.L'Access); | |
1716 | pragma Assert (Result = 0); | |
1717 | ||
1718 | -- Destroy internal condition variable | |
1719 | ||
1720 | Result := cond_destroy (S.CV'Access); | |
1721 | pragma Assert (Result = 0); | |
1722 | end Finalize; | |
1723 | ||
1724 | ------------------- | |
1725 | -- Current_State -- | |
1726 | ------------------- | |
1727 | ||
1728 | function Current_State (S : Suspension_Object) return Boolean is | |
1729 | begin | |
1730 | -- We do not want to use lock on this read operation. State is marked | |
1731 | -- as Atomic so that we ensure that the value retrieved is correct. | |
1732 | ||
1733 | return S.State; | |
1734 | end Current_State; | |
1735 | ||
1736 | --------------- | |
1737 | -- Set_False -- | |
1738 | --------------- | |
1739 | ||
1740 | procedure Set_False (S : in out Suspension_Object) is | |
1741 | Result : Interfaces.C.int; | |
dae22b53 | 1742 | |
b497b460 | 1743 | begin |
72774950 JR |
1744 | SSL.Abort_Defer.all; |
1745 | ||
b497b460 JR |
1746 | Result := mutex_lock (S.L'Access); |
1747 | pragma Assert (Result = 0); | |
1748 | ||
1749 | S.State := False; | |
1750 | ||
1751 | Result := mutex_unlock (S.L'Access); | |
1752 | pragma Assert (Result = 0); | |
72774950 JR |
1753 | |
1754 | SSL.Abort_Undefer.all; | |
b497b460 JR |
1755 | end Set_False; |
1756 | ||
1757 | -------------- | |
1758 | -- Set_True -- | |
1759 | -------------- | |
1760 | ||
1761 | procedure Set_True (S : in out Suspension_Object) is | |
1762 | Result : Interfaces.C.int; | |
dae22b53 | 1763 | |
b497b460 | 1764 | begin |
72774950 JR |
1765 | SSL.Abort_Defer.all; |
1766 | ||
b497b460 JR |
1767 | Result := mutex_lock (S.L'Access); |
1768 | pragma Assert (Result = 0); | |
1769 | ||
1770 | -- If there is already a task waiting on this suspension object then | |
1771 | -- we resume it, leaving the state of the suspension object to False, | |
1772 | -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves | |
1773 | -- the state to True. | |
1774 | ||
1775 | if S.Waiting then | |
1776 | S.Waiting := False; | |
1777 | S.State := False; | |
1778 | ||
1779 | Result := cond_signal (S.CV'Access); | |
1780 | pragma Assert (Result = 0); | |
dae22b53 | 1781 | |
b497b460 JR |
1782 | else |
1783 | S.State := True; | |
1784 | end if; | |
1785 | ||
1786 | Result := mutex_unlock (S.L'Access); | |
1787 | pragma Assert (Result = 0); | |
72774950 JR |
1788 | |
1789 | SSL.Abort_Undefer.all; | |
b497b460 JR |
1790 | end Set_True; |
1791 | ||
1792 | ------------------------ | |
1793 | -- Suspend_Until_True -- | |
1794 | ------------------------ | |
1795 | ||
1796 | procedure Suspend_Until_True (S : in out Suspension_Object) is | |
1797 | Result : Interfaces.C.int; | |
dae22b53 | 1798 | |
b497b460 | 1799 | begin |
72774950 JR |
1800 | SSL.Abort_Defer.all; |
1801 | ||
b497b460 JR |
1802 | Result := mutex_lock (S.L'Access); |
1803 | pragma Assert (Result = 0); | |
1804 | ||
1805 | if S.Waiting then | |
dae22b53 | 1806 | |
b497b460 JR |
1807 | -- Program_Error must be raised upon calling Suspend_Until_True |
1808 | -- if another task is already waiting on that suspension object | |
dae22b53 | 1809 | -- (RM D.10(10)). |
b497b460 JR |
1810 | |
1811 | Result := mutex_unlock (S.L'Access); | |
1812 | pragma Assert (Result = 0); | |
1813 | ||
72774950 JR |
1814 | SSL.Abort_Undefer.all; |
1815 | ||
b497b460 | 1816 | raise Program_Error; |
dae22b53 | 1817 | |
b497b460 JR |
1818 | else |
1819 | -- Suspend the task if the state is False. Otherwise, the task | |
1820 | -- continues its execution, and the state of the suspension object | |
1821 | -- is set to False (ARM D.10 par. 9). | |
1822 | ||
1823 | if S.State then | |
1824 | S.State := False; | |
1825 | else | |
1826 | S.Waiting := True; | |
1827 | Result := cond_wait (S.CV'Access, S.L'Access); | |
1828 | end if; | |
b497b460 | 1829 | |
72774950 JR |
1830 | Result := mutex_unlock (S.L'Access); |
1831 | pragma Assert (Result = 0); | |
1832 | ||
1833 | SSL.Abort_Undefer.all; | |
1834 | end if; | |
b497b460 JR |
1835 | end Suspend_Until_True; |
1836 | ||
84481f76 RK |
1837 | ---------------- |
1838 | -- Check_Exit -- | |
1839 | ---------------- | |
1840 | ||
b5e792e2 | 1841 | function Check_Exit (Self_ID : Task_Id) return Boolean is |
84481f76 | 1842 | begin |
8dbb621e | 1843 | -- Check that caller is just holding Global_Task_Lock and no other locks |
84481f76 RK |
1844 | |
1845 | if Self_ID.Common.LL.Locks = null then | |
1846 | return False; | |
1847 | end if; | |
1848 | ||
1849 | -- 2 = Global_Task_Level | |
1850 | ||
1851 | if Self_ID.Common.LL.Locks.Level /= 2 then | |
1852 | return False; | |
1853 | end if; | |
1854 | ||
1855 | if Self_ID.Common.LL.Locks.Next /= null then | |
1856 | return False; | |
1857 | end if; | |
1858 | ||
1859 | -- Check that caller is abort-deferred | |
1860 | ||
f02b8bb8 | 1861 | if Self_ID.Deferral_Level = 0 then |
84481f76 RK |
1862 | return False; |
1863 | end if; | |
1864 | ||
1865 | return True; | |
1866 | end Check_Exit; | |
1867 | ||
1868 | -------------------- | |
1869 | -- Check_No_Locks -- | |
1870 | -------------------- | |
1871 | ||
b5e792e2 | 1872 | function Check_No_Locks (Self_ID : Task_Id) return Boolean is |
84481f76 RK |
1873 | begin |
1874 | return Self_ID.Common.LL.Locks = null; | |
1875 | end Check_No_Locks; | |
1876 | ||
1877 | ---------------------- | |
1878 | -- Environment_Task -- | |
1879 | ---------------------- | |
1880 | ||
b5e792e2 | 1881 | function Environment_Task return Task_Id is |
84481f76 | 1882 | begin |
b5e792e2 | 1883 | return Environment_Task_Id; |
84481f76 RK |
1884 | end Environment_Task; |
1885 | ||
07fc65c4 GB |
1886 | -------------- |
1887 | -- Lock_RTS -- | |
1888 | -------------- | |
84481f76 | 1889 | |
07fc65c4 | 1890 | procedure Lock_RTS is |
84481f76 | 1891 | begin |
07fc65c4 GB |
1892 | Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); |
1893 | end Lock_RTS; | |
84481f76 | 1894 | |
07fc65c4 GB |
1895 | ---------------- |
1896 | -- Unlock_RTS -- | |
1897 | ---------------- | |
84481f76 | 1898 | |
07fc65c4 | 1899 | procedure Unlock_RTS is |
84481f76 | 1900 | begin |
07fc65c4 GB |
1901 | Unlock (Single_RTS_Lock'Access, Global_Lock => True); |
1902 | end Unlock_RTS; | |
84481f76 RK |
1903 | |
1904 | ------------------ | |
1905 | -- Suspend_Task -- | |
1906 | ------------------ | |
1907 | ||
1908 | function Suspend_Task | |
b5e792e2 | 1909 | (T : ST.Task_Id; |
8a6a52dc | 1910 | Thread_Self : Thread_Id) return Boolean |
fbf5a39b | 1911 | is |
84481f76 RK |
1912 | begin |
1913 | if T.Common.LL.Thread /= Thread_Self then | |
1914 | return thr_suspend (T.Common.LL.Thread) = 0; | |
1915 | else | |
1916 | return True; | |
1917 | end if; | |
1918 | end Suspend_Task; | |
1919 | ||
1920 | ----------------- | |
1921 | -- Resume_Task -- | |
1922 | ----------------- | |
1923 | ||
1924 | function Resume_Task | |
b5e792e2 | 1925 | (T : ST.Task_Id; |
8a6a52dc | 1926 | Thread_Self : Thread_Id) return Boolean |
fbf5a39b | 1927 | is |
84481f76 RK |
1928 | begin |
1929 | if T.Common.LL.Thread /= Thread_Self then | |
1930 | return thr_continue (T.Common.LL.Thread) = 0; | |
1931 | else | |
1932 | return True; | |
1933 | end if; | |
1934 | end Resume_Task; | |
1935 | ||
c9b9ec14 JG |
1936 | -------------------- |
1937 | -- Stop_All_Tasks -- | |
1938 | -------------------- | |
1939 | ||
1940 | procedure Stop_All_Tasks is | |
1941 | begin | |
1942 | null; | |
1943 | end Stop_All_Tasks; | |
1944 | ||
ed18d858 JG |
1945 | --------------- |
1946 | -- Stop_Task -- | |
1947 | --------------- | |
1948 | ||
1949 | function Stop_Task (T : ST.Task_Id) return Boolean is | |
1950 | pragma Unreferenced (T); | |
1951 | begin | |
1952 | return False; | |
1953 | end Stop_Task; | |
1954 | ||
c9b9ec14 JG |
1955 | ------------------- |
1956 | -- Continue_Task -- | |
1957 | ------------------- | |
1958 | ||
1959 | function Continue_Task (T : ST.Task_Id) return Boolean is | |
1960 | pragma Unreferenced (T); | |
1961 | begin | |
1962 | return False; | |
1963 | end Continue_Task; | |
1964 | ||
84481f76 | 1965 | end System.Task_Primitives.Operations; |