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