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