File : s-taprop-linux-xenomai.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNU ADA 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-2011, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT 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 3, or (at your option) any later ver- --
14 -- sion. GNAT 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. --
17 -- --
18 -- --
19 -- --
20 -- --
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/>. --
26 -- --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 -- This is a GNU/Linux (Xenomai) version of this package
33
34 -- This package contains all the GNULL primitives that interface directly with
35 -- the underlying OS.
36
37 pragma Polling (Off);
38 -- Turn off polling, we do not want ATC polling to take place during tasking
39 -- operations. It causes infinite loops and other problems.
40
41 with Ada.Unchecked_Conversion;
42
43 with Interfaces.C;
44
45 with System.Task_Info;
46 with System.Tasking.Debug;
47 with System.Interrupt_Management;
48 with System.OS_Primitives;
49 with System.Stack_Checking.Operations;
50
51 with System.Soft_Links;
52 -- We use System.Soft_Links instead of System.Tasking.Initialization
53 -- because the later is a higher level package that we shouldn't depend on.
54 -- For example when using the restricted run time, it is replaced by
55 -- System.Tasking.Restricted.Stages.
56
57 package body System.Task_Primitives.Operations is
58
59 package SSL renames System.Soft_Links;
60 package SC renames System.Stack_Checking.Operations;
61
62 use System.Tasking.Debug;
63 use System.Tasking;
64 use Interfaces.C;
65 use System.OS_Interface;
66 use System.Parameters;
67 use System.OS_Primitives;
68 use System.Task_Info;
69
70 ----------------
71 -- Local Data --
72 ----------------
73
74 -- The followings are logically constants, but need to be initialized
75 -- at run time.
76
77 Single_RTS_Lock : aliased RTS_Lock;
78 -- This is a lock to allow only one thread of control in the RTS at
79 -- a time; it is used to execute in mutual exclusion from all other tasks.
80 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
81
82 Environment_Task_Id : Task_Id;
83 -- A variable to hold Task_Id for the environment task
84
85 Unblocked_Signal_Mask : aliased sigset_t;
86 -- The set of signals that should be unblocked in all tasks
87
88 -- The followings are internal configuration constants needed
89
90 Next_Serial_Number : Task_Serial_Number := 100;
91 -- We start at 100 (reserve some special values for using in error checks)
92
93 Foreign_Task_Elaborated : aliased Boolean := True;
94 -- Used to identified fake tasks (i.e., non-Ada Threads)
95
96 Infinite : constant := 0;
97 -- Value used to indicate that when waiting for a mutex or a condition
98 -- variable the caller needs to block indefinitely until the object is
99 -- available.
100
101 Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0;
102 -- Whether to use an alternate signal stack for stack overflows
103
104 Abort_Handler_Installed : Boolean := False;
105 -- True if a handler for the abort signal is installed
106
107 --------------------
108 -- Local Packages --
109 --------------------
110
111 package Specific is
112
113 procedure Initialize (Environment_Task : Task_Id);
114 pragma Inline (Initialize);
115 -- Initialize various data needed by this package
116
117 function Is_Valid_Task return Boolean;
118 pragma Inline (Is_Valid_Task);
119 -- Does executing thread have a TCB?
120
121 procedure Set (Self_Id : Task_Id);
122 pragma Inline (Set);
123 -- Set the self id for the current task
124
125 function Self return Task_Id;
126 pragma Inline (Self);
127 -- Return a pointer to the Ada Task Control Block of the calling task
128
129 end Specific;
130
131 package body Specific is separate;
132 -- The body of this package is target specific
133
134 ----------------------------------
135 -- ATCB allocation/deallocation --
136 ----------------------------------
137
138 package body ATCB_Allocation is separate;
139 -- The body of this package is shared across several targets
140
141 ---------------------------------
142 -- Support for foreign threads --
143 ---------------------------------
144
145 function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
146 -- Allocate and Initialize a new ATCB for the current Thread
147
148 function Register_Foreign_Thread
149 (Thread : Thread_Id) return Task_Id is separate;
150
151 -----------------------
152 -- Local Subprograms --
153 -----------------------
154
155 procedure Abort_Handler (signo : Signal);
156
157 function To_RTime (D : Duration) return RTime;
158 pragma Inline (To_RTime);
159
160 -------------------
161 -- Abort_Handler --
162 -------------------
163
164 procedure Abort_Handler (signo : Signal) is
165 pragma Unreferenced (signo);
166
167 Self_Id : constant Task_Id := Self;
168 Result : Interfaces.C.int;
169 Old_Set : aliased sigset_t;
170
171 begin
172 -- It's not safe to raise an exception when using GCC ZCX mechanism.
173 -- Note that we still need to install a signal handler, since in some
174 -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we
175 -- need to send the Abort signal to a task.
176
177 if ZCX_By_Default then
178 return;
179 end if;
180
181 if Self_Id.Deferral_Level = 0
182 and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level
183 and then not Self_Id.Aborting
184 then
185 Self_Id.Aborting := True;
186
187 -- Make sure signals used for RTS internal purpose are unmasked
188
189 Result :=
190 pthread_sigmask
191 (SIG_UNBLOCK,
192 Unblocked_Signal_Mask'Access,
193 Old_Set'Access);
194 pragma Assert (Result = 0);
195
196 raise Standard'Abort_Signal;
197 end if;
198 end Abort_Handler;
199
200 --------------
201 -- To_RTime --
202 --------------
203
204 function To_RTime (D : Duration) return RTime is
205 Result : RTime;
206
207 function To_SRTime is new Ada.Unchecked_Conversion (Duration, SRTime);
208 -- Duration and SRTime are 64-bits types containing a count of
209 -- nanoseconds so we can do unchecked conversions between them.
210
211 begin
212 Result := RTime (timer_ns2ticks (To_SRTime (D)));
213
214 -- The value RTime'(0) has an special meaning (infinite) so we must
215 -- avoid this value in the translation.
216
217 if Result = 0 then
218 Result := 1;
219 end if;
220
221 return Result;
222 end To_RTime;
223
224 --------------
225 -- Lock_RTS --
226 --------------
227
228 procedure Lock_RTS is
229 begin
230 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
231 end Lock_RTS;
232
233 ----------------
234 -- Unlock_RTS --
235 ----------------
236
237 procedure Unlock_RTS is
238 begin
239 Unlock (Single_RTS_Lock'Access, Global_Lock => True);
240 end Unlock_RTS;
241
242 -----------------
243 -- Stack_Guard --
244 -----------------
245
246 -- The underlying thread system extends the memory (up to 2MB) when needed
247
248 procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
249 pragma Unreferenced (T);
250 pragma Unreferenced (On);
251 begin
252 null;
253 end Stack_Guard;
254
255 --------------------
256 -- Get_Thread_Id --
257 --------------------
258
259 function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
260 begin
261 return T.Common.LL.Thread;
262 end Get_Thread_Id;
263
264 ----------
265 -- Self --
266 ----------
267
268 function Self return Task_Id renames Specific.Self;
269
270 ---------------------
271 -- Initialize_Lock --
272 ---------------------
273
274 -- Note: mutexes and cond_variables needed per-task basis are initialized
275 -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
276 -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
277 -- status change of RTS. Therefore raising Storage_Error in the following
278 -- routines should be able to be handled safely.
279
280 procedure Initialize_Lock
281 (Prio : System.Any_Priority;
282 L : not null access Lock)
283 is
284 pragma Unreferenced (Prio);
285
286 Result : Interfaces.C.int;
287
288 begin
289 Result := mutex_create (L, null);
290
291 pragma Assert (Result = 0 or else Result = ENOMEM);
292
293 if Result = ENOMEM then
294 raise Storage_Error with "Failed to allocate a lock";
295 end if;
296 end Initialize_Lock;
297
298 procedure Initialize_Lock
299 (L : not null access RTS_Lock;
300 Level : Lock_Level)
301 is
302 pragma Unreferenced (Level);
303
304 Result : Interfaces.C.int;
305
306 begin
307 Result := mutex_create (L, null);
308
309 pragma Assert (Result = 0 or else Result = ENOMEM);
310
311 if Result = ENOMEM then
312 raise Storage_Error;
313 end if;
314 end Initialize_Lock;
315
316 -------------------
317 -- Finalize_Lock --
318 -------------------
319
320 procedure Finalize_Lock (L : not null access Lock) is
321 Result : Interfaces.C.int;
322 begin
323 Result := mutex_delete (L);
324 pragma Assert (Result = 0);
325 end Finalize_Lock;
326
327 procedure Finalize_Lock (L : not null access RTS_Lock) is
328 Result : Interfaces.C.int;
329 begin
330 Result := mutex_delete (L);
331 pragma Assert (Result = 0);
332 end Finalize_Lock;
333
334 ----------------
335 -- Write_Lock --
336 ----------------
337
338 procedure Write_Lock
339 (L : not null access Lock;
340 Ceiling_Violation : out Boolean)
341 is
342 Result : Interfaces.C.int;
343 begin
344 Result := mutex_lock (L, Infinite);
345
346 -- Mutexes implement the priority inheritance protocol so we cannot
347 -- check here for priority ceiling violations.
348
349 Ceiling_Violation := False;
350
351 pragma Assert (Result = 0);
352 end Write_Lock;
353
354 procedure Write_Lock
355 (L : not null access RTS_Lock;
356 Global_Lock : Boolean := False)
357 is
358 Result : Interfaces.C.int;
359 begin
360 if not Single_Lock or else Global_Lock then
361 Result := mutex_lock (L, Infinite);
362 pragma Assert (Result = 0);
363 end if;
364 end Write_Lock;
365
366 procedure Write_Lock (T : Task_Id) is
367 Result : Interfaces.C.int;
368 begin
369 if not Single_Lock then
370 Result := mutex_lock (T.Common.LL.L'Access, Infinite);
371 pragma Assert (Result = 0);
372 end if;
373 end Write_Lock;
374
375 ---------------
376 -- Read_Lock --
377 ---------------
378
379 procedure Read_Lock
380 (L : not null access Lock;
381 Ceiling_Violation : out Boolean)
382 is
383 begin
384 Write_Lock (L, Ceiling_Violation);
385 end Read_Lock;
386
387 ------------
388 -- Unlock --
389 ------------
390
391 procedure Unlock (L : not null access Lock) is
392 Result : Interfaces.C.int;
393 begin
394 Result := mutex_unlock (L);
395 pragma Assert (Result = 0);
396 end Unlock;
397
398 procedure Unlock
399 (L : not null access RTS_Lock;
400 Global_Lock : Boolean := False)
401 is
402 Result : Interfaces.C.int;
403 begin
404 if not Single_Lock or else Global_Lock then
405 Result := mutex_unlock (L);
406 pragma Assert (Result = 0);
407 end if;
408 end Unlock;
409
410 procedure Unlock (T : Task_Id) is
411 Result : Interfaces.C.int;
412 begin
413 if not Single_Lock then
414 Result := mutex_unlock (T.Common.LL.L'Access);
415 pragma Assert (Result = 0);
416 end if;
417 end Unlock;
418
419 -----------------
420 -- Set_Ceiling --
421 -----------------
422
423 -- Dynamic priority ceilings are not supported by the underlying system
424
425 procedure Set_Ceiling
426 (L : not null access Lock;
427 Prio : System.Any_Priority)
428 is
429 pragma Unreferenced (L, Prio);
430 begin
431 null;
432 end Set_Ceiling;
433
434 -----------
435 -- Sleep --
436 -----------
437
438 procedure Sleep
439 (Self_ID : Task_Id;
440 Reason : System.Tasking.Task_States)
441 is
442 pragma Unreferenced (Reason);
443
444 Result : Interfaces.C.int;
445
446 begin
447 pragma Assert (Self_ID = Self);
448
449 if Single_Lock then
450 Result :=
451 cond_wait
452 (Self_ID.Common.LL.CV'Access,
453 Single_RTS_Lock'Access,
454 Infinite);
455 else
456 Result :=
457 cond_wait
458 (Self_ID.Common.LL.CV'Access,
459 Self_ID.Common.LL.L'Access,
460 Infinite);
461 end if;
462
463 -- EINTR is not considered a failure
464
465 pragma Assert (Result = 0 or else Result = EINTR);
466 end Sleep;
467
468 -----------------
469 -- Timed_Sleep --
470 -----------------
471
472 -- This is for use within the run-time system, so abort is
473 -- assumed to be already deferred, and the caller should be
474 -- holding its own ATCB lock.
475
476 procedure Timed_Sleep
477 (Self_ID : Task_Id;
478 Time : Duration;
479 Mode : ST.Delay_Modes;
480 Reason : System.Tasking.Task_States;
481 Timedout : out Boolean;
482 Yielded : out Boolean)
483 is
484 pragma Unreferenced (Reason);
485
486 Now : Duration := Monotonic_Clock;
487 Abs_Time : Duration;
488 Ticks : RTime;
489 Result : Interfaces.C.int;
490
491 begin
492 Timedout := True;
493 Yielded := False;
494
495 -- Relative delay
496
497 if Mode = Relative then
498 if Time > 0.0 then
499 Abs_Time := Now + Time;
500 Ticks := To_RTime (Time);
501
502 -- Ticks equal to zero indicates that the expiration time has
503 -- already passed and no delay is needed.
504
505 else
506 Abs_Time := Now;
507 Ticks := 0;
508 end if;
509
510 -- Absolute delay
511
512 else
513 Abs_Time := Time;
514
515 if Abs_Time > Now then
516 Ticks := To_RTime (Abs_Time - Now);
517
518 -- Ticks equal to zero indicates that the expiration time has
519 -- already passed and no delay is needed.
520
521 else
522 Ticks := 0;
523 end if;
524 end if;
525
526 if Ticks /= 0 then
527 loop
528 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
529
530 if Single_Lock then
531 Result :=
532 cond_wait
533 (Self_ID.Common.LL.CV'Access,
534 Single_RTS_Lock'Access,
535 Ticks);
536 else
537 Result :=
538 cond_wait
539 (Self_ID.Common.LL.CV'Access,
540 Self_ID.Common.LL.L'Access,
541 Ticks);
542 end if;
543
544 pragma Assert
545 (Result = 0 or else Result = ETIMEDOUT or else Result = EINTR);
546
547 if Result = 0 or else Result = EINTR then
548
549 -- Somebody may have called Wakeup for us
550
551 Timedout := False;
552 exit;
553
554 else
555 Now := Monotonic_Clock;
556
557 exit when Abs_Time <= Now;
558
559 Ticks := To_RTime (Abs_Time - Now);
560 end if;
561 end loop;
562 end if;
563 end Timed_Sleep;
564
565 -----------------
566 -- Timed_Delay --
567 -----------------
568
569 -- This is for use in implementing delay statements, so we assume the
570 -- caller is abort-deferred but is holding no locks.
571
572 procedure Timed_Delay
573 (Self_ID : Task_Id;
574 Time : Duration;
575 Mode : ST.Delay_Modes)
576 is
577 Now : Duration := Monotonic_Clock;
578 Abs_Time : Duration;
579 Ticks : RTime;
580 Result : Interfaces.C.int;
581
582 begin
583 -- Relative delay
584
585 if Mode = Relative then
586 if Time > 0.0 then
587 Abs_Time := Now + Time;
588 Ticks := To_RTime (Time);
589
590 -- Ticks equal to zero indicates that the expiration time has
591 -- already passed and no delay is needed (but it may dispatch).
592
593 else
594 Abs_Time := Now;
595 Ticks := 0;
596 end if;
597
598 -- Absolute delay
599
600 else
601 Abs_Time := Time;
602
603 if Abs_Time > Now then
604 Ticks := To_RTime (Abs_Time - Now);
605
606 -- Ticks equal to zero indicates that the expiration time has
607 -- already passed and no delay is needed (but it may dispatch).
608
609 else
610 Ticks := 0;
611 end if;
612 end if;
613
614 if Ticks /= 0 then
615 -- Modifying State, locking the TCB
616
617 if Single_Lock then
618 Lock_RTS;
619 else
620 Write_Lock (Self_ID);
621 end if;
622
623 Self_ID.Common.State := Delay_Sleep;
624
625 loop
626 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
627
628 if Single_Lock then
629 Result :=
630 cond_wait
631 (Self_ID.Common.LL.CV'Access,
632 Single_RTS_Lock'Access,
633 Ticks);
634 else
635 Result :=
636 cond_wait
637 (Self_ID.Common.LL.CV'Access,
638 Self_ID.Common.LL.L'Access,
639 Ticks);
640 end if;
641
642 pragma Assert
643 (Result = 0 or else Result = ETIMEDOUT or else Result = EINTR);
644
645 Now := Monotonic_Clock;
646
647 if Abs_Time > Now then
648 Ticks := To_RTime (Abs_Time - Now);
649 else
650 exit;
651 end if;
652 end loop;
653
654 Self_ID.Common.State := Runnable;
655
656 if Single_Lock then
657 Unlock_RTS;
658 else
659 Unlock (Self_ID);
660 end if;
661
662 else
663 Result := sched_yield;
664 pragma Assert (Result = 0);
665 end if;
666 end Timed_Delay;
667
668 ---------------------
669 -- Monotonic_Clock --
670 ---------------------
671
672 function Monotonic_Clock return Duration
673 renames System.OS_Primitives.Monotonic_Clock;
674
675 -------------------
676 -- RT_Resolution --
677 -------------------
678
679 function RT_Resolution return Duration is
680 begin
681 return Duration (timer_ticks2ns (1_000_000)) / 1_000_000_000_000_000.0;
682 end RT_Resolution;
683
684 ------------
685 -- Wakeup --
686 ------------
687
688 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
689 pragma Unreferenced (Reason);
690 Result : Interfaces.C.int;
691 begin
692 Result := cond_signal (T.Common.LL.CV'Access);
693 pragma Assert (Result = 0);
694 end Wakeup;
695
696 -----------
697 -- Yield --
698 -----------
699
700 procedure Yield (Do_Yield : Boolean := True) is
701 Result : Interfaces.C.int;
702 pragma Unreferenced (Result);
703 begin
704 if Do_Yield then
705 Result := sched_yield;
706 end if;
707 end Yield;
708
709 ------------------
710 -- Set_Priority --
711 ------------------
712
713 procedure Set_Priority
714 (T : Task_Id;
715 Prio : System.Any_Priority;
716 Loss_Of_Inheritance : Boolean := False)
717 is
718 pragma Unreferenced (Loss_Of_Inheritance);
719
720 Result : Interfaces.C.int;
721 pragma Unreferenced (Result);
722 begin
723 T.Common.Current_Priority := Prio;
724
725 -- Priorities are 1 .. 99 on Xenomai, so we map 0 .. 98 to 1 .. 99
726
727 Result := task_set_priority (T.Common.LL.Thread, int (Prio) + 1);
728 end Set_Priority;
729
730 ------------------
731 -- Get_Priority --
732 ------------------
733
734 function Get_Priority (T : Task_Id) return System.Any_Priority is
735 begin
736 return T.Common.Current_Priority;
737 end Get_Priority;
738
739 ----------------
740 -- Enter_Task --
741 ----------------
742
743 procedure Enter_Task (Self_ID : Task_Id) is
744 begin
745 Self_ID.Common.LL.Thread := thread_self;
746 Self_ID.Common.LL.LWP := lwp_self;
747 Self_ID.Common.LL.PThread := pthread_self;
748 -- The POSIX thread identifier is needed for POSIX signal handling
749
750 Specific.Set (Self_ID);
751
752 if Use_Alternate_Stack then
753 declare
754 Stack : aliased stack_t;
755 Result : Interfaces.C.int;
756 begin
757 Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack;
758 Stack.ss_size := Alternate_Stack_Size;
759 Stack.ss_flags := 0;
760 Result := sigaltstack (Stack'Access, null);
761 pragma Assert (Result = 0);
762 end;
763 end if;
764 end Enter_Task;
765
766 -------------------
767 -- Is_Valid_Task --
768 -------------------
769
770 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
771
772 -----------------------------
773 -- Register_Foreign_Thread --
774 -----------------------------
775
776 function Register_Foreign_Thread return Task_Id is
777 begin
778 if Is_Valid_Task then
779 return Self;
780 else
781 return Register_Foreign_Thread (thread_self);
782 end if;
783 end Register_Foreign_Thread;
784
785 --------------------
786 -- Initialize_TCB --
787 --------------------
788
789 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
790 Result : Interfaces.C.int;
791
792 begin
793 -- Give the task a unique serial number
794
795 Self_ID.Serial_Number := Next_Serial_Number;
796 Next_Serial_Number := Next_Serial_Number + 1;
797 pragma Assert (Next_Serial_Number /= 0);
798
799 Self_ID.Common.LL.Thread := thread_self;
800
801 if not Single_Lock then
802 Result := mutex_create (Self_ID.Common.LL.L'Access, null);
803 pragma Assert (Result = 0 or else Result = ENOMEM);
804
805 if Result /= 0 then
806 Succeeded := False;
807 return;
808 end if;
809 end if;
810
811 Result := cond_create (Self_ID.Common.LL.CV'Access, null);
812 pragma Assert (Result = 0 or else Result = ENOMEM);
813
814 if Result = 0 then
815 Succeeded := True;
816 else
817 if not Single_Lock then
818 Result := mutex_delete (Self_ID.Common.LL.L'Access);
819 pragma Assert (Result = 0);
820 end if;
821
822 Succeeded := False;
823 end if;
824 end Initialize_TCB;
825
826 -----------------
827 -- Create_Task --
828 -----------------
829
830 procedure Create_Task
831 (T : Task_Id;
832 Wrapper : System.Address;
833 Stack_Size : System.Parameters.Size_Type;
834 Priority : System.Any_Priority;
835 Succeeded : out Boolean)
836 is
837 Adjusted_Stack_Size : Interfaces.C.size_t;
838 Result : Interfaces.C.int;
839
840 begin
841 Adjusted_Stack_Size :=
842 Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size);
843
844 Result := task_create
845 (T.Common.LL.Thread,
846 null,
847 Adjusted_Stack_Size,
848 int (Priority),
849 0);
850 pragma Assert
851 (Result = 0 or else Result = EAGAIN or else Result = ENOMEM);
852
853 if Result /= 0 then
854 Succeeded := False;
855 return;
856 end if;
857
858 Result := task_start
859 (T.Common.LL.Thread,
860 Thread_Body_Access (Wrapper),
861 To_Address (T));
862 pragma Assert
863 (Result = 0 or else Result = EAGAIN or else Result = ENOMEM);
864
865 if Result /= 0 then
866 Succeeded := False;
867 Result := task_delete (T.Common.LL.Thread);
868 pragma Assert (Result = 0);
869 return;
870 end if;
871
872 Succeeded := True;
873
874 Set_Priority (T, Priority);
875 end Create_Task;
876
877 ------------------
878 -- Finalize_TCB --
879 ------------------
880
881 procedure Finalize_TCB (T : Task_Id) is
882 Result : Interfaces.C.int;
883
884 begin
885 if not Single_Lock then
886 Result := mutex_delete (T.Common.LL.L'Access);
887 pragma Assert (Result = 0);
888 end if;
889
890 Result := cond_delete (T.Common.LL.CV'Access);
891 pragma Assert (Result = 0);
892
893 if T.Known_Tasks_Index /= -1 then
894 Known_Tasks (T.Known_Tasks_Index) := null;
895 end if;
896 SC.Invalidate_Stack_Cache (T.Common.Compiler_Data.Pri_Stack_Info'Access);
897
898 ATCB_Allocation.Free_ATCB (T);
899 end Finalize_TCB;
900
901 ---------------
902 -- Exit_Task --
903 ---------------
904
905 procedure Exit_Task is
906 begin
907 Specific.Set (null);
908 end Exit_Task;
909
910 ----------------
911 -- Abort_Task --
912 ----------------
913
914 procedure Abort_Task (T : Task_Id) is
915 Result : Interfaces.C.int;
916 begin
917 if Abort_Handler_Installed then
918 Result :=
919 pthread_kill
920 (T.Common.LL.PThread,
921 Signal (System.Interrupt_Management.Abort_Task_Interrupt));
922 pragma Assert (Result = 0);
923 end if;
924 end Abort_Task;
925
926 ----------------
927 -- Initialize --
928 ----------------
929
930 procedure Initialize (S : in out Suspension_Object) is
931 Result : Interfaces.C.int;
932
933 begin
934 -- Initialize internal state (always to False (RM D.10(6)))
935
936 S.State := False;
937 S.Waiting := False;
938
939 -- Initialize internal mutex
940
941 Result := mutex_create (S.L'Access, null);
942
943 pragma Assert (Result = 0 or else Result = ENOMEM);
944
945 if Result = ENOMEM then
946 raise Storage_Error;
947 end if;
948
949 -- Initialize internal condition variable
950
951 Result := cond_create (S.CV'Access, null);
952
953 pragma Assert (Result = 0 or else Result = ENOMEM);
954
955 if Result /= 0 then
956 Result := mutex_delete (S.L'Access);
957 pragma Assert (Result = 0);
958
959 if Result = ENOMEM then
960 raise Storage_Error;
961 end if;
962 end if;
963 end Initialize;
964
965 --------------
966 -- Finalize --
967 --------------
968
969 procedure Finalize (S : in out Suspension_Object) is
970 Result : Interfaces.C.int;
971
972 begin
973 -- Destroy internal mutex
974
975 Result := mutex_delete (S.L'Access);
976 pragma Assert (Result = 0);
977
978 -- Destroy internal condition variable
979
980 Result := cond_delete (S.CV'Access);
981 pragma Assert (Result = 0);
982 end Finalize;
983
984 -------------------
985 -- Current_State --
986 -------------------
987
988 function Current_State (S : Suspension_Object) return Boolean is
989 begin
990 -- We do not want to use lock on this read operation. State is marked
991 -- as Atomic so that we ensure that the value retrieved is correct.
992
993 return S.State;
994 end Current_State;
995
996 ---------------
997 -- Set_False --
998 ---------------
999
1000 procedure Set_False (S : in out Suspension_Object) is
1001 Result : Interfaces.C.int;
1002
1003 begin
1004 SSL.Abort_Defer.all;
1005
1006 Result := mutex_lock (S.L'Access, Infinite);
1007 pragma Assert (Result = 0);
1008
1009 S.State := False;
1010
1011 Result := mutex_unlock (S.L'Access);
1012 pragma Assert (Result = 0);
1013
1014 SSL.Abort_Undefer.all;
1015 end Set_False;
1016
1017 --------------
1018 -- Set_True --
1019 --------------
1020
1021 procedure Set_True (S : in out Suspension_Object) is
1022 Result : Interfaces.C.int;
1023
1024 begin
1025 SSL.Abort_Defer.all;
1026
1027 Result := mutex_lock (S.L'Access, Infinite);
1028 pragma Assert (Result = 0);
1029
1030 -- If there is already a task waiting on this suspension object then
1031 -- we resume it, leaving the state of the suspension object to False,
1032 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1033 -- the state to True.
1034
1035 if S.Waiting then
1036 S.Waiting := False;
1037 S.State := False;
1038
1039 Result := cond_signal (S.CV'Access);
1040 pragma Assert (Result = 0);
1041
1042 else
1043 S.State := True;
1044 end if;
1045
1046 Result := mutex_unlock (S.L'Access);
1047 pragma Assert (Result = 0);
1048
1049 SSL.Abort_Undefer.all;
1050 end Set_True;
1051
1052 ------------------------
1053 -- Suspend_Until_True --
1054 ------------------------
1055
1056 procedure Suspend_Until_True (S : in out Suspension_Object) is
1057 Result : Interfaces.C.int;
1058
1059 begin
1060 SSL.Abort_Defer.all;
1061
1062 Result := mutex_lock (S.L'Access, Infinite);
1063 pragma Assert (Result = 0);
1064
1065 if S.Waiting then
1066
1067 -- Program_Error must be raised upon calling Suspend_Until_True
1068 -- if another task is already waiting on that suspension object
1069 -- (RM D.10(10)).
1070
1071 Result := mutex_unlock (S.L'Access);
1072 pragma Assert (Result = 0);
1073
1074 SSL.Abort_Undefer.all;
1075
1076 raise Program_Error;
1077 else
1078 -- Suspend the task if the state is False. Otherwise, the task
1079 -- continues its execution, and the state of the suspension object
1080 -- is set to False (ARM D.10 par. 9).
1081
1082 if S.State then
1083 S.State := False;
1084 else
1085 S.Waiting := True;
1086 Result := cond_wait (S.CV'Access, S.L'Access, Infinite);
1087 end if;
1088
1089 Result := mutex_unlock (S.L'Access);
1090 pragma Assert (Result = 0);
1091
1092 SSL.Abort_Undefer.all;
1093 end if;
1094 end Suspend_Until_True;
1095
1096 ----------------
1097 -- Check_Exit --
1098 ----------------
1099
1100 -- Dummy version
1101
1102 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1103 pragma Unreferenced (Self_ID);
1104 begin
1105 return True;
1106 end Check_Exit;
1107
1108 --------------------
1109 -- Check_No_Locks --
1110 --------------------
1111
1112 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1113 pragma Unreferenced (Self_ID);
1114 begin
1115 return True;
1116 end Check_No_Locks;
1117
1118 ----------------------
1119 -- Environment_Task --
1120 ----------------------
1121
1122 function Environment_Task return Task_Id is
1123 begin
1124 return Environment_Task_Id;
1125 end Environment_Task;
1126
1127 ------------------
1128 -- Suspend_Task --
1129 ------------------
1130
1131 function Suspend_Task
1132 (T : ST.Task_Id;
1133 Thread_Self : Thread_Id) return Boolean
1134 is
1135 begin
1136 if T.Common.LL.Thread /= null
1137 and then T.Common.LL.Thread /= Thread_Self
1138 then
1139 return task_suspend (T.Common.LL.Thread) = 0;
1140 else
1141 return True;
1142 end if;
1143 end Suspend_Task;
1144
1145 -----------------
1146 -- Resume_Task --
1147 -----------------
1148
1149 function Resume_Task
1150 (T : ST.Task_Id;
1151 Thread_Self : Thread_Id) return Boolean
1152 is
1153 begin
1154 if T.Common.LL.Thread /= null
1155 and then T.Common.LL.Thread /= Thread_Self
1156 then
1157 return task_resume (T.Common.LL.Thread) = 0;
1158 else
1159 return True;
1160 end if;
1161 end Resume_Task;
1162
1163 --------------------
1164 -- Stop_All_Tasks --
1165 --------------------
1166
1167 procedure Stop_All_Tasks is
1168 begin
1169 null;
1170 end Stop_All_Tasks;
1171
1172 ---------------
1173 -- Stop_Task --
1174 ---------------
1175
1176 function Stop_Task (T : ST.Task_Id) return Boolean is
1177 pragma Unreferenced (T);
1178 begin
1179 return False;
1180 end Stop_Task;
1181
1182 -------------------
1183 -- Continue_Task --
1184 -------------------
1185
1186 function Continue_Task (T : ST.Task_Id) return Boolean is
1187 pragma Unreferenced (T);
1188 begin
1189 return False;
1190 end Continue_Task;
1191
1192 ----------------
1193 -- Initialize --
1194 ----------------
1195
1196 procedure Initialize (Environment_Task : Task_Id) is
1197 act : aliased struct_sigaction;
1198 old_act : aliased struct_sigaction;
1199 Tmp_Set : aliased sigset_t;
1200 Result : Interfaces.C.int;
1201 -- Whether to use an alternate signal stack for stack overflows
1202
1203 function State
1204 (Int : System.Interrupt_Management.Interrupt_ID) return Character;
1205 pragma Import (C, State, "__gnat_get_interrupt_state");
1206 -- Get interrupt state. Defined in a-init.c
1207 -- The input argument is the interrupt number,
1208 -- and the result is one of the following:
1209
1210 Default : constant Character := 's';
1211 -- 'n' this interrupt not set by any Interrupt_State pragma
1212 -- 'u' Interrupt_State pragma set state to User
1213 -- 'r' Interrupt_State pragma set state to Runtime
1214 -- 's' Interrupt_State pragma set state to System (use "default"
1215 -- system handler)
1216
1217 begin
1218 Environment_Task_Id := Environment_Task;
1219
1220 Interrupt_Management.Initialize;
1221
1222 -- Prepare the set of signals that should be unblocked in all tasks
1223
1224 Result := sigemptyset (Unblocked_Signal_Mask'Access);
1225 pragma Assert (Result = 0);
1226
1227 for J in Interrupt_Management.Interrupt_ID loop
1228 if System.Interrupt_Management.Keep_Unmasked (J) then
1229 Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
1230 pragma Assert (Result = 0);
1231 end if;
1232 end loop;
1233
1234 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1235
1236 -- Initialize the global RTS lock
1237
1238 Specific.Initialize (Environment_Task);
1239
1240 if Use_Alternate_Stack then
1241 Environment_Task.Common.Task_Alternate_Stack :=
1242 Alternate_Stack'Address;
1243 end if;
1244
1245 -- Make environment task known here because it doesn't go through
1246 -- Activate_Tasks, which does it for all other tasks.
1247
1248 Known_Tasks (Known_Tasks'First) := Environment_Task;
1249 Environment_Task.Known_Tasks_Index := Known_Tasks'First;
1250
1251 Enter_Task (Environment_Task);
1252
1253 if State
1254 (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
1255 then
1256 act.sa_flags := 0;
1257 act.sa_handler := Abort_Handler'Address;
1258
1259 Result := sigemptyset (Tmp_Set'Access);
1260 pragma Assert (Result = 0);
1261 act.sa_mask := Tmp_Set;
1262
1263 Result :=
1264 sigaction
1265 (Signal (Interrupt_Management.Abort_Task_Interrupt),
1266 act'Unchecked_Access,
1267 old_act'Unchecked_Access);
1268 pragma Assert (Result = 0);
1269 Abort_Handler_Installed := True;
1270 end if;
1271 end Initialize;
1272
1273 -----------------------
1274 -- Set_Task_Affinity --
1275 -----------------------
1276
1277 procedure Set_Task_Affinity (T : ST.Task_Id) is
1278 pragma Unreferenced (T);
1279
1280 begin
1281 -- Setting task affinity is not supported by the underlying system
1282
1283 null;
1284 end Set_Task_Affinity;
1285
1286 end System.Task_Primitives.Operations;