OSDN Git Service

* a-calend-mingw.adb: Add call to OS_Primitives.Initialize;
[pf3gnuchains/gcc-fork.git] / gcc / ada / s-taprop-posix.adb
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 POSIX-like version of this package
35
36 --  This package contains all the GNULL primitives that interface directly
37 --  with the underlying OS.
38
39 --  Note: this file can only be used for POSIX compliant systems that
40 --  implement SCHED_FIFO and Ceiling Locking correctly.
41
42 --  For configurations where SCHED_FIFO and priority ceiling are not a
43 --  requirement, this file can also be used (e.g AiX threads)
44
45 pragma Polling (Off);
46 --  Turn off polling, we do not want ATC polling to take place during
47 --  tasking operations. It causes infinite loops and other problems.
48
49 with System.Tasking.Debug;
50 --  used for Known_Tasks
51
52 with System.Interrupt_Management;
53 --  used for Keep_Unmasked
54 --           Abort_Task_Interrupt
55 --           Interrupt_ID
56
57 with System.OS_Primitives;
58 --  used for Delay_Modes
59
60 with System.Task_Info;
61 --  used for Task_Info_Type
62
63 with Interfaces.C;
64 --  used for int
65 --           size_t
66
67 with System.Parameters;
68 --  used for Size_Type
69
70 with Unchecked_Conversion;
71 with Unchecked_Deallocation;
72
73 package body System.Task_Primitives.Operations is
74
75    use System.Tasking.Debug;
76    use System.Tasking;
77    use Interfaces.C;
78    use System.OS_Interface;
79    use System.Parameters;
80    use System.OS_Primitives;
81
82    ----------------
83    -- Local Data --
84    ----------------
85
86    --  The followings are logically constants, but need to be initialized
87    --  at run time.
88
89    Single_RTS_Lock : aliased RTS_Lock;
90    --  This is a lock to allow only one thread of control in the RTS at
91    --  a time; it is used to execute in mutual exclusion from all other tasks.
92    --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
93
94    ATCB_Key : aliased pthread_key_t;
95    --  Key used to find the Ada Task_Id associated with a thread
96
97    Environment_Task_Id : Task_Id;
98    --  A variable to hold Task_Id for the environment task.
99
100    Locking_Policy : Character;
101    pragma Import (C, Locking_Policy, "__gl_locking_policy");
102    --  Value of the pragma Locking_Policy:
103    --    'C' for Ceiling_Locking
104    --    'I' for Inherit_Locking
105    --    ' ' for none.
106
107    Unblocked_Signal_Mask : aliased sigset_t;
108    --  The set of signals that should unblocked in all tasks
109
110    --  The followings are internal configuration constants needed.
111
112    Next_Serial_Number : Task_Serial_Number := 100;
113    --  We start at 100, to reserve some special values for
114    --  using in error checking.
115
116    Time_Slice_Val : Integer;
117    pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
118
119    Dispatching_Policy : Character;
120    pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
121
122    Foreign_Task_Elaborated : aliased Boolean := True;
123    --  Used to identified fake tasks (i.e., non-Ada Threads).
124
125    --------------------
126    -- Local Packages --
127    --------------------
128
129    package Specific is
130
131       procedure Initialize (Environment_Task : Task_Id);
132       pragma Inline (Initialize);
133       --  Initialize various data needed by this package.
134
135       function Is_Valid_Task return Boolean;
136       pragma Inline (Is_Valid_Task);
137       --  Does executing thread have a TCB?
138
139       procedure Set (Self_Id : Task_Id);
140       pragma Inline (Set);
141       --  Set the self id for the current task.
142
143       function Self return Task_Id;
144       pragma Inline (Self);
145       --  Return a pointer to the Ada Task Control Block of the calling task.
146
147    end Specific;
148
149    package body Specific is separate;
150    --  The body of this package is target specific.
151
152    ---------------------------------
153    -- Support for foreign threads --
154    ---------------------------------
155
156    function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
157    --  Allocate and Initialize a new ATCB for the current Thread.
158
159    function Register_Foreign_Thread
160      (Thread : Thread_Id) return Task_Id is separate;
161
162    -----------------------
163    -- Local Subprograms --
164    -----------------------
165
166    procedure Abort_Handler (Sig : Signal);
167    --  Signal handler used to implement asynchronous abort.
168    --  See also comment before body, below.
169
170    function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
171
172    -------------------
173    -- Abort_Handler --
174    -------------------
175
176    --  Target-dependent binding of inter-thread Abort signal to
177    --  the raising of the Abort_Signal exception.
178
179    --  The technical issues and alternatives here are essentially
180    --  the same as for raising exceptions in response to other
181    --  signals (e.g. Storage_Error). See code and comments in
182    --  the package body System.Interrupt_Management.
183
184    --  Some implementations may not allow an exception to be propagated
185    --  out of a handler, and others might leave the signal or
186    --  interrupt that invoked this handler masked after the exceptional
187    --  return to the application code.
188
189    --  GNAT exceptions are originally implemented using setjmp()/longjmp().
190    --  On most UNIX systems, this will allow transfer out of a signal handler,
191    --  which is usually the only mechanism available for implementing
192    --  asynchronous handlers of this kind. However, some
193    --  systems do not restore the signal mask on longjmp(), leaving the
194    --  abort signal masked.
195
196    procedure Abort_Handler (Sig : Signal) is
197       pragma Warnings (Off, Sig);
198
199       T       : constant Task_Id := Self;
200       Result  : Interfaces.C.int;
201       Old_Set : aliased sigset_t;
202
203    begin
204       --  It is not safe to raise an exception when using ZCX and the GCC
205       --  exception handling mechanism.
206
207       if ZCX_By_Default and then GCC_ZCX_Support then
208          return;
209       end if;
210
211       if T.Deferral_Level = 0
212         and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then
213         not T.Aborting
214       then
215          T.Aborting := True;
216
217          --  Make sure signals used for RTS internal purpose are unmasked
218
219          Result := pthread_sigmask (SIG_UNBLOCK,
220            Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
221          pragma Assert (Result = 0);
222
223          raise Standard'Abort_Signal;
224       end if;
225    end Abort_Handler;
226
227    -----------------
228    -- Stack_Guard --
229    -----------------
230
231    procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
232       Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread);
233       Guard_Page_Address : Address;
234
235       Res : Interfaces.C.int;
236
237    begin
238       if Stack_Base_Available then
239
240          --  Compute the guard page address
241
242          Guard_Page_Address :=
243            Stack_Base - (Stack_Base mod Get_Page_Size) + Get_Page_Size;
244
245          if On then
246             Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_ON);
247          else
248             Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_OFF);
249          end if;
250
251          pragma Assert (Res = 0);
252       end if;
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
275    --        initialized in Intialize_TCB and the Storage_Error is
276    --        handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
277    --        used in RTS is initialized before any status change of RTS.
278    --        Therefore rasing Storage_Error in the following routines
279    --        should be able to be handled safely.
280
281    procedure Initialize_Lock
282      (Prio : System.Any_Priority;
283       L    : access Lock)
284    is
285       Attributes : aliased pthread_mutexattr_t;
286       Result : Interfaces.C.int;
287
288    begin
289       Result := pthread_mutexattr_init (Attributes'Access);
290       pragma Assert (Result = 0 or else Result = ENOMEM);
291
292       if Result = ENOMEM then
293          raise Storage_Error;
294       end if;
295
296       if Locking_Policy = 'C' then
297          Result := pthread_mutexattr_setprotocol
298            (Attributes'Access, PTHREAD_PRIO_PROTECT);
299          pragma Assert (Result = 0);
300
301          Result := pthread_mutexattr_setprioceiling
302             (Attributes'Access, Interfaces.C.int (Prio));
303          pragma Assert (Result = 0);
304
305       elsif Locking_Policy = 'I' then
306          Result := pthread_mutexattr_setprotocol
307            (Attributes'Access, PTHREAD_PRIO_INHERIT);
308          pragma Assert (Result = 0);
309       end if;
310
311       Result := pthread_mutex_init (L, Attributes'Access);
312       pragma Assert (Result = 0 or else Result = ENOMEM);
313
314       if Result = ENOMEM then
315          raise Storage_Error;
316       end if;
317
318       Result := pthread_mutexattr_destroy (Attributes'Access);
319       pragma Assert (Result = 0);
320    end Initialize_Lock;
321
322    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
323       pragma Warnings (Off, Level);
324
325       Attributes : aliased pthread_mutexattr_t;
326       Result     : Interfaces.C.int;
327
328    begin
329       Result := pthread_mutexattr_init (Attributes'Access);
330       pragma Assert (Result = 0 or else Result = ENOMEM);
331
332       if Result = ENOMEM then
333          raise Storage_Error;
334       end if;
335
336       if Locking_Policy = 'C' then
337          Result := pthread_mutexattr_setprotocol
338            (Attributes'Access, PTHREAD_PRIO_PROTECT);
339          pragma Assert (Result = 0);
340
341          Result := pthread_mutexattr_setprioceiling
342             (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
343          pragma Assert (Result = 0);
344
345       elsif Locking_Policy = 'I' then
346          Result := pthread_mutexattr_setprotocol
347            (Attributes'Access, PTHREAD_PRIO_INHERIT);
348          pragma Assert (Result = 0);
349       end if;
350
351       Result := pthread_mutex_init (L, Attributes'Access);
352       pragma Assert (Result = 0 or else Result = ENOMEM);
353
354       if Result = ENOMEM then
355          Result := pthread_mutexattr_destroy (Attributes'Access);
356          raise Storage_Error;
357       end if;
358
359       Result := pthread_mutexattr_destroy (Attributes'Access);
360       pragma Assert (Result = 0);
361    end Initialize_Lock;
362
363    -------------------
364    -- Finalize_Lock --
365    -------------------
366
367    procedure Finalize_Lock (L : access Lock) is
368       Result : Interfaces.C.int;
369
370    begin
371       Result := pthread_mutex_destroy (L);
372       pragma Assert (Result = 0);
373    end Finalize_Lock;
374
375    procedure Finalize_Lock (L : access RTS_Lock) is
376       Result : Interfaces.C.int;
377
378    begin
379       Result := pthread_mutex_destroy (L);
380       pragma Assert (Result = 0);
381    end Finalize_Lock;
382
383    ----------------
384    -- Write_Lock --
385    ----------------
386
387    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
388       Result : Interfaces.C.int;
389
390    begin
391       Result := pthread_mutex_lock (L);
392
393       --  Assume that the cause of EINVAL is a priority ceiling violation
394
395       Ceiling_Violation := (Result = EINVAL);
396       pragma Assert (Result = 0 or else Result = EINVAL);
397    end Write_Lock;
398
399    procedure Write_Lock
400      (L           : access RTS_Lock;
401       Global_Lock : Boolean := False)
402    is
403       Result : Interfaces.C.int;
404
405    begin
406       if not Single_Lock or else Global_Lock then
407          Result := pthread_mutex_lock (L);
408          pragma Assert (Result = 0);
409       end if;
410    end Write_Lock;
411
412    procedure Write_Lock (T : Task_Id) is
413       Result : Interfaces.C.int;
414
415    begin
416       if not Single_Lock then
417          Result := pthread_mutex_lock (T.Common.LL.L'Access);
418          pragma Assert (Result = 0);
419       end if;
420    end Write_Lock;
421
422    ---------------
423    -- Read_Lock --
424    ---------------
425
426    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
427    begin
428       Write_Lock (L, Ceiling_Violation);
429    end Read_Lock;
430
431    ------------
432    -- Unlock --
433    ------------
434
435    procedure Unlock (L : access Lock) is
436       Result : Interfaces.C.int;
437
438    begin
439       Result := pthread_mutex_unlock (L);
440       pragma Assert (Result = 0);
441    end Unlock;
442
443    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
444       Result : Interfaces.C.int;
445
446    begin
447       if not Single_Lock or else Global_Lock then
448          Result := pthread_mutex_unlock (L);
449          pragma Assert (Result = 0);
450       end if;
451    end Unlock;
452
453    procedure Unlock (T : Task_Id) is
454       Result : Interfaces.C.int;
455
456    begin
457       if not Single_Lock then
458          Result := pthread_mutex_unlock (T.Common.LL.L'Access);
459          pragma Assert (Result = 0);
460       end if;
461    end Unlock;
462
463    -----------
464    -- Sleep --
465    -----------
466
467    procedure Sleep
468      (Self_ID : Task_Id;
469       Reason   : System.Tasking.Task_States)
470    is
471       pragma Warnings (Off, Reason);
472
473       Result : Interfaces.C.int;
474
475    begin
476       if Single_Lock then
477          Result := pthread_cond_wait
478            (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
479       else
480          Result := pthread_cond_wait
481            (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
482       end if;
483
484       --  EINTR is not considered a failure.
485
486       pragma Assert (Result = 0 or else Result = EINTR);
487    end Sleep;
488
489    -----------------
490    -- Timed_Sleep --
491    -----------------
492
493    --  This is for use within the run-time system, so abort is
494    --  assumed to be already deferred, and the caller should be
495    --  holding its own ATCB lock.
496
497    procedure Timed_Sleep
498      (Self_ID  : Task_Id;
499       Time     : Duration;
500       Mode     : ST.Delay_Modes;
501       Reason   : Task_States;
502       Timedout : out Boolean;
503       Yielded  : out Boolean)
504    is
505       pragma Warnings (Off, Reason);
506
507       Check_Time : constant Duration := Monotonic_Clock;
508       Rel_Time   : Duration;
509       Abs_Time   : Duration;
510       Request    : aliased timespec;
511       Result     : Interfaces.C.int;
512
513    begin
514       Timedout := True;
515       Yielded := False;
516
517       if Mode = Relative then
518          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
519
520          if Relative_Timed_Wait then
521             Rel_Time := Duration'Min (Max_Sensible_Delay, Time);
522          end if;
523
524       else
525          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
526
527          if Relative_Timed_Wait then
528             Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time);
529          end if;
530       end if;
531
532       if Abs_Time > Check_Time then
533          if Relative_Timed_Wait then
534             Request := To_Timespec (Rel_Time);
535          else
536             Request := To_Timespec (Abs_Time);
537          end if;
538
539          loop
540             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
541               or else Self_ID.Pending_Priority_Change;
542
543             if Single_Lock then
544                Result := pthread_cond_timedwait
545                  (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
546                   Request'Access);
547
548             else
549                Result := pthread_cond_timedwait
550                  (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
551                   Request'Access);
552             end if;
553
554             exit when Abs_Time <= Monotonic_Clock;
555
556             if Result = 0 or Result = EINTR then
557
558                --  Somebody may have called Wakeup for us
559
560                Timedout := False;
561                exit;
562             end if;
563
564             pragma Assert (Result = ETIMEDOUT);
565          end loop;
566       end if;
567    end Timed_Sleep;
568
569    -----------------
570    -- Timed_Delay --
571    -----------------
572
573    --  This is for use in implementing delay statements, so
574    --  we assume the caller is abort-deferred but is holding
575    --  no locks.
576
577    procedure Timed_Delay
578      (Self_ID  : Task_Id;
579       Time     : Duration;
580       Mode     : ST.Delay_Modes)
581    is
582       Check_Time : constant Duration := Monotonic_Clock;
583       Abs_Time   : Duration;
584       Rel_Time   : Duration;
585       Request    : aliased timespec;
586       Result     : Interfaces.C.int;
587
588    begin
589       if Single_Lock then
590          Lock_RTS;
591       end if;
592
593       Write_Lock (Self_ID);
594
595       if Mode = Relative then
596          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
597
598          if Relative_Timed_Wait then
599             Rel_Time := Duration'Min (Max_Sensible_Delay, Time);
600          end if;
601
602       else
603          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
604
605          if Relative_Timed_Wait then
606             Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time);
607          end if;
608       end if;
609
610       if Abs_Time > Check_Time then
611          if Relative_Timed_Wait then
612             Request := To_Timespec (Rel_Time);
613          else
614             Request := To_Timespec (Abs_Time);
615          end if;
616
617          Self_ID.Common.State := Delay_Sleep;
618
619          loop
620             if Self_ID.Pending_Priority_Change then
621                Self_ID.Pending_Priority_Change := False;
622                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
623                Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
624             end if;
625
626             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
627
628             if Single_Lock then
629                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
630                  Single_RTS_Lock'Access, Request'Access);
631             else
632                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
633                  Self_ID.Common.LL.L'Access, Request'Access);
634             end if;
635
636             exit when Abs_Time <= Monotonic_Clock;
637
638             pragma Assert (Result = 0
639                              or else Result = ETIMEDOUT
640                              or else Result = EINTR);
641          end loop;
642
643          Self_ID.Common.State := Runnable;
644       end if;
645
646       Unlock (Self_ID);
647
648       if Single_Lock then
649          Unlock_RTS;
650       end if;
651
652       Result := sched_yield;
653    end Timed_Delay;
654
655    ---------------------
656    -- Monotonic_Clock --
657    ---------------------
658
659    function Monotonic_Clock return Duration is
660       TS     : aliased timespec;
661       Result : Interfaces.C.int;
662    begin
663       Result := clock_gettime
664         (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access);
665       pragma Assert (Result = 0);
666       return To_Duration (TS);
667    end Monotonic_Clock;
668
669    -------------------
670    -- RT_Resolution --
671    -------------------
672
673    function RT_Resolution return Duration is
674    begin
675       return 10#1.0#E-6;
676    end RT_Resolution;
677
678    ------------
679    -- Wakeup --
680    ------------
681
682    procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
683       pragma Warnings (Off, Reason);
684       Result : Interfaces.C.int;
685    begin
686       Result := pthread_cond_signal (T.Common.LL.CV'Access);
687       pragma Assert (Result = 0);
688    end Wakeup;
689
690    -----------
691    -- Yield --
692    -----------
693
694    procedure Yield (Do_Yield : Boolean := True) is
695       Result : Interfaces.C.int;
696       pragma Unreferenced (Result);
697    begin
698       if Do_Yield then
699          Result := sched_yield;
700       end if;
701    end Yield;
702
703    ------------------
704    -- Set_Priority --
705    ------------------
706
707    procedure Set_Priority
708      (T                   : Task_Id;
709       Prio                : System.Any_Priority;
710       Loss_Of_Inheritance : Boolean := False)
711    is
712       pragma Warnings (Off, Loss_Of_Inheritance);
713
714       Result : Interfaces.C.int;
715       Param  : aliased struct_sched_param;
716
717    begin
718       T.Common.Current_Priority := Prio;
719       Param.sched_priority := Interfaces.C.int (Prio);
720
721       if Time_Slice_Supported and then Time_Slice_Val > 0 then
722          Result := pthread_setschedparam
723            (T.Common.LL.Thread, SCHED_RR, Param'Access);
724
725       elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
726          Result := pthread_setschedparam
727            (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
728
729       else
730          Result := pthread_setschedparam
731            (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
732       end if;
733
734       pragma Assert (Result = 0);
735    end Set_Priority;
736
737    ------------------
738    -- Get_Priority --
739    ------------------
740
741    function Get_Priority (T : Task_Id) return System.Any_Priority is
742    begin
743       return T.Common.Current_Priority;
744    end Get_Priority;
745
746    ----------------
747    -- Enter_Task --
748    ----------------
749
750    procedure Enter_Task (Self_ID : Task_Id) is
751    begin
752       Self_ID.Common.LL.Thread := pthread_self;
753       Self_ID.Common.LL.LWP := lwp_self;
754
755       Specific.Set (Self_ID);
756
757       Lock_RTS;
758
759       for J in Known_Tasks'Range loop
760          if Known_Tasks (J) = null then
761             Known_Tasks (J) := Self_ID;
762             Self_ID.Known_Tasks_Index := J;
763             exit;
764          end if;
765       end loop;
766
767       Unlock_RTS;
768    end Enter_Task;
769
770    --------------
771    -- New_ATCB --
772    --------------
773
774    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
775    begin
776       return new Ada_Task_Control_Block (Entry_Num);
777    end New_ATCB;
778
779    -------------------
780    -- Is_Valid_Task --
781    -------------------
782
783    function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
784
785    -----------------------------
786    -- Register_Foreign_Thread --
787    -----------------------------
788
789    function Register_Foreign_Thread return Task_Id is
790    begin
791       if Is_Valid_Task then
792          return Self;
793       else
794          return Register_Foreign_Thread (pthread_self);
795       end if;
796    end Register_Foreign_Thread;
797
798    --------------------
799    -- Initialize_TCB --
800    --------------------
801
802    procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
803       Mutex_Attr : aliased pthread_mutexattr_t;
804       Result     : Interfaces.C.int;
805       Cond_Attr  : aliased pthread_condattr_t;
806
807    begin
808       --  Give the task a unique serial number.
809
810       Self_ID.Serial_Number := Next_Serial_Number;
811       Next_Serial_Number := Next_Serial_Number + 1;
812       pragma Assert (Next_Serial_Number /= 0);
813
814       if not Single_Lock then
815          Result := pthread_mutexattr_init (Mutex_Attr'Access);
816          pragma Assert (Result = 0 or else Result = ENOMEM);
817
818          if Result = 0 then
819             if Locking_Policy = 'C' then
820                Result := pthread_mutexattr_setprotocol
821                  (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT);
822                pragma Assert (Result = 0);
823
824                Result := pthread_mutexattr_setprioceiling
825                   (Mutex_Attr'Access,
826                    Interfaces.C.int (System.Any_Priority'Last));
827                pragma Assert (Result = 0);
828
829             elsif Locking_Policy = 'I' then
830                Result := pthread_mutexattr_setprotocol
831                  (Mutex_Attr'Access, PTHREAD_PRIO_INHERIT);
832                pragma Assert (Result = 0);
833             end if;
834
835             Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
836               Mutex_Attr'Access);
837             pragma Assert (Result = 0 or else Result = ENOMEM);
838          end if;
839
840          if Result /= 0 then
841             Succeeded := False;
842             return;
843          end if;
844
845          Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
846          pragma Assert (Result = 0);
847       end if;
848
849       Result := pthread_condattr_init (Cond_Attr'Access);
850       pragma Assert (Result = 0 or else Result = ENOMEM);
851
852       if Result = 0 then
853          Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
854            Cond_Attr'Access);
855          pragma Assert (Result = 0 or else Result = ENOMEM);
856       end if;
857
858       if Result = 0 then
859          Succeeded := True;
860       else
861          if not Single_Lock then
862             Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
863             pragma Assert (Result = 0);
864          end if;
865
866          Succeeded := False;
867       end if;
868
869       Result := pthread_condattr_destroy (Cond_Attr'Access);
870       pragma Assert (Result = 0);
871    end Initialize_TCB;
872
873    -----------------
874    -- Create_Task --
875    -----------------
876
877    procedure Create_Task
878      (T          : Task_Id;
879       Wrapper    : System.Address;
880       Stack_Size : System.Parameters.Size_Type;
881       Priority   : System.Any_Priority;
882       Succeeded  : out Boolean)
883    is
884       Attributes          : aliased pthread_attr_t;
885       Adjusted_Stack_Size : Interfaces.C.size_t;
886       Result              : Interfaces.C.int;
887
888       function Thread_Body_Access is new
889         Unchecked_Conversion (System.Address, Thread_Body);
890
891       use System.Task_Info;
892
893    begin
894       if Stack_Size = Unspecified_Size then
895          Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size);
896
897       elsif Stack_Size < Minimum_Stack_Size then
898          Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
899
900       else
901          Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
902       end if;
903
904       if Stack_Base_Available then
905          --  If Stack Checking is supported then allocate 2 additional pages:
906          --
907          --  In the worst case, stack is allocated at something like
908          --  N * Get_Page_Size - epsilon, we need to add the size for 2 pages
909          --  to be sure the effective stack size is greater than what
910          --  has been asked.
911
912          Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Get_Page_Size;
913       end if;
914
915       Result := pthread_attr_init (Attributes'Access);
916       pragma Assert (Result = 0 or else Result = ENOMEM);
917
918       if Result /= 0 then
919          Succeeded := False;
920          return;
921       end if;
922
923       Result := pthread_attr_setdetachstate
924         (Attributes'Access, PTHREAD_CREATE_DETACHED);
925       pragma Assert (Result = 0);
926
927       Result := pthread_attr_setstacksize
928         (Attributes'Access, Adjusted_Stack_Size);
929       pragma Assert (Result = 0);
930
931       if T.Common.Task_Info /= Default_Scope then
932
933          --  We are assuming that Scope_Type has the same values than the
934          --  corresponding C macros
935
936          Result := pthread_attr_setscope
937            (Attributes'Access, Task_Info_Type'Pos (T.Common.Task_Info));
938          pragma Assert (Result = 0);
939       end if;
940
941       --  Since the initial signal mask of a thread is inherited from the
942       --  creator, and the Environment task has all its signals masked, we
943       --  do not need to manipulate caller's signal mask at this point.
944       --  All tasks in RTS will have All_Tasks_Mask initially.
945
946       Result := pthread_create
947         (T.Common.LL.Thread'Access,
948          Attributes'Access,
949          Thread_Body_Access (Wrapper),
950          To_Address (T));
951       pragma Assert (Result = 0 or else Result = EAGAIN);
952
953       Succeeded := Result = 0;
954
955       Result := pthread_attr_destroy (Attributes'Access);
956       pragma Assert (Result = 0);
957
958       Set_Priority (T, Priority);
959    end Create_Task;
960
961    ------------------
962    -- Finalize_TCB --
963    ------------------
964
965    procedure Finalize_TCB (T : Task_Id) is
966       Result  : Interfaces.C.int;
967       Tmp     : Task_Id := T;
968       Is_Self : constant Boolean := T = Self;
969
970       procedure Free is new
971         Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
972
973    begin
974       if not Single_Lock then
975          Result := pthread_mutex_destroy (T.Common.LL.L'Access);
976          pragma Assert (Result = 0);
977       end if;
978
979       Result := pthread_cond_destroy (T.Common.LL.CV'Access);
980       pragma Assert (Result = 0);
981
982       if T.Known_Tasks_Index /= -1 then
983          Known_Tasks (T.Known_Tasks_Index) := null;
984       end if;
985
986       Free (Tmp);
987
988       if Is_Self then
989          Specific.Set (null);
990       end if;
991    end Finalize_TCB;
992
993    ---------------
994    -- Exit_Task --
995    ---------------
996
997    procedure Exit_Task is
998    begin
999       --  Mark this task as unknown, so that if Self is called, it won't
1000       --  return a dangling pointer.
1001
1002       Specific.Set (null);
1003    end Exit_Task;
1004
1005    ----------------
1006    -- Abort_Task --
1007    ----------------
1008
1009    procedure Abort_Task (T : Task_Id) is
1010       Result : Interfaces.C.int;
1011    begin
1012       Result := pthread_kill (T.Common.LL.Thread,
1013         Signal (System.Interrupt_Management.Abort_Task_Interrupt));
1014       pragma Assert (Result = 0);
1015    end Abort_Task;
1016
1017    ----------------
1018    -- Initialize --
1019    ----------------
1020
1021    procedure Initialize (S : in out Suspension_Object) is
1022       Mutex_Attr : aliased pthread_mutexattr_t;
1023       Cond_Attr  : aliased pthread_condattr_t;
1024       Result     : Interfaces.C.int;
1025    begin
1026       --  Initialize internal state. It is always initialized to False (ARM
1027       --  D.10 par. 6).
1028
1029       S.State := False;
1030       S.Waiting := False;
1031
1032       --  Initialize internal mutex
1033
1034       Result := pthread_mutexattr_init (Mutex_Attr'Access);
1035       pragma Assert (Result = 0 or else Result = ENOMEM);
1036
1037       if Result = ENOMEM then
1038          raise Storage_Error;
1039       end if;
1040
1041       Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
1042       pragma Assert (Result = 0 or else Result = ENOMEM);
1043
1044       if Result = ENOMEM then
1045          Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
1046          pragma Assert (Result = 0);
1047
1048          raise Storage_Error;
1049       end if;
1050
1051       Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
1052       pragma Assert (Result = 0);
1053
1054       --  Initialize internal condition variable
1055
1056       Result := pthread_condattr_init (Cond_Attr'Access);
1057       pragma Assert (Result = 0 or else Result = ENOMEM);
1058
1059       if Result /= 0 then
1060          Result := pthread_mutex_destroy (S.L'Access);
1061          pragma Assert (Result = 0);
1062
1063          if Result = ENOMEM then
1064             raise Storage_Error;
1065          end if;
1066       end if;
1067
1068       Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
1069       pragma Assert (Result = 0 or else Result = ENOMEM);
1070
1071       if Result /= 0 then
1072          Result := pthread_mutex_destroy (S.L'Access);
1073          pragma Assert (Result = 0);
1074
1075          if Result = ENOMEM then
1076             Result := pthread_condattr_destroy (Cond_Attr'Access);
1077             pragma Assert (Result = 0);
1078
1079             raise Storage_Error;
1080          end if;
1081       end if;
1082
1083       Result := pthread_condattr_destroy (Cond_Attr'Access);
1084       pragma Assert (Result = 0);
1085    end Initialize;
1086
1087    --------------
1088    -- Finalize --
1089    --------------
1090
1091    procedure Finalize (S : in out Suspension_Object) is
1092       Result  : Interfaces.C.int;
1093    begin
1094       --  Destroy internal mutex
1095
1096       Result := pthread_mutex_destroy (S.L'Access);
1097       pragma Assert (Result = 0);
1098
1099       --  Destroy internal condition variable
1100
1101       Result := pthread_cond_destroy (S.CV'Access);
1102       pragma Assert (Result = 0);
1103    end Finalize;
1104
1105    -------------------
1106    -- Current_State --
1107    -------------------
1108
1109    function Current_State (S : Suspension_Object) return Boolean is
1110    begin
1111       --  We do not want to use lock on this read operation. State is marked
1112       --  as Atomic so that we ensure that the value retrieved is correct.
1113
1114       return S.State;
1115    end Current_State;
1116
1117    ---------------
1118    -- Set_False --
1119    ---------------
1120
1121    procedure Set_False (S : in out Suspension_Object) is
1122       Result  : Interfaces.C.int;
1123    begin
1124       Result := pthread_mutex_lock (S.L'Access);
1125       pragma Assert (Result = 0);
1126
1127       S.State := False;
1128
1129       Result := pthread_mutex_unlock (S.L'Access);
1130       pragma Assert (Result = 0);
1131    end Set_False;
1132
1133    --------------
1134    -- Set_True --
1135    --------------
1136
1137    procedure Set_True (S : in out Suspension_Object) is
1138       Result : Interfaces.C.int;
1139    begin
1140       Result := pthread_mutex_lock (S.L'Access);
1141       pragma Assert (Result = 0);
1142
1143       --  If there is already a task waiting on this suspension object then
1144       --  we resume it, leaving the state of the suspension object to False,
1145       --  as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1146       --  the state to True.
1147
1148       if S.Waiting then
1149          S.Waiting := False;
1150          S.State := False;
1151
1152          Result := pthread_cond_signal (S.CV'Access);
1153          pragma Assert (Result = 0);
1154       else
1155          S.State := True;
1156       end if;
1157
1158       Result := pthread_mutex_unlock (S.L'Access);
1159       pragma Assert (Result = 0);
1160    end Set_True;
1161
1162    ------------------------
1163    -- Suspend_Until_True --
1164    ------------------------
1165
1166    procedure Suspend_Until_True (S : in out Suspension_Object) is
1167       Result : Interfaces.C.int;
1168    begin
1169       Result := pthread_mutex_lock (S.L'Access);
1170       pragma Assert (Result = 0);
1171
1172       if S.Waiting then
1173          --  Program_Error must be raised upon calling Suspend_Until_True
1174          --  if another task is already waiting on that suspension object
1175          --  (ARM D.10 par. 10).
1176
1177          Result := pthread_mutex_unlock (S.L'Access);
1178          pragma Assert (Result = 0);
1179
1180          raise Program_Error;
1181       else
1182          --  Suspend the task if the state is False. Otherwise, the task
1183          --  continues its execution, and the state of the suspension object
1184          --  is set to False (ARM D.10 par. 9).
1185
1186          if S.State then
1187             S.State := False;
1188          else
1189             S.Waiting := True;
1190             Result := pthread_cond_wait (S.CV'Access, S.L'Access);
1191          end if;
1192       end if;
1193
1194       Result := pthread_mutex_unlock (S.L'Access);
1195       pragma Assert (Result = 0);
1196    end Suspend_Until_True;
1197
1198    ----------------
1199    -- Check_Exit --
1200    ----------------
1201
1202    --  Dummy version
1203
1204    function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1205       pragma Warnings (Off, Self_ID);
1206    begin
1207       return True;
1208    end Check_Exit;
1209
1210    --------------------
1211    -- Check_No_Locks --
1212    --------------------
1213
1214    function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1215       pragma Warnings (Off, Self_ID);
1216    begin
1217       return True;
1218    end Check_No_Locks;
1219
1220    ----------------------
1221    -- Environment_Task --
1222    ----------------------
1223
1224    function Environment_Task return Task_Id is
1225    begin
1226       return Environment_Task_Id;
1227    end Environment_Task;
1228
1229    --------------
1230    -- Lock_RTS --
1231    --------------
1232
1233    procedure Lock_RTS is
1234    begin
1235       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1236    end Lock_RTS;
1237
1238    ----------------
1239    -- Unlock_RTS --
1240    ----------------
1241
1242    procedure Unlock_RTS is
1243    begin
1244       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1245    end Unlock_RTS;
1246
1247    ------------------
1248    -- Suspend_Task --
1249    ------------------
1250
1251    function Suspend_Task
1252      (T           : ST.Task_Id;
1253       Thread_Self : Thread_Id) return Boolean
1254    is
1255       pragma Warnings (Off, T);
1256       pragma Warnings (Off, Thread_Self);
1257    begin
1258       return False;
1259    end Suspend_Task;
1260
1261    -----------------
1262    -- Resume_Task --
1263    -----------------
1264
1265    function Resume_Task
1266      (T           : ST.Task_Id;
1267       Thread_Self : Thread_Id) return Boolean
1268    is
1269       pragma Warnings (Off, T);
1270       pragma Warnings (Off, Thread_Self);
1271    begin
1272       return False;
1273    end Resume_Task;
1274
1275    ----------------
1276    -- Initialize --
1277    ----------------
1278
1279    procedure Initialize (Environment_Task : Task_Id) is
1280       act     : aliased struct_sigaction;
1281       old_act : aliased struct_sigaction;
1282       Tmp_Set : aliased sigset_t;
1283       Result  : Interfaces.C.int;
1284
1285       function State
1286         (Int : System.Interrupt_Management.Interrupt_ID) return Character;
1287       pragma Import (C, State, "__gnat_get_interrupt_state");
1288       --  Get interrupt state.  Defined in a-init.c
1289       --  The input argument is the interrupt number,
1290       --  and the result is one of the following:
1291
1292       Default : constant Character := 's';
1293       --    'n'   this interrupt not set by any Interrupt_State pragma
1294       --    'u'   Interrupt_State pragma set state to User
1295       --    'r'   Interrupt_State pragma set state to Runtime
1296       --    's'   Interrupt_State pragma set state to System (use "default"
1297       --           system handler)
1298
1299    begin
1300       Environment_Task_Id := Environment_Task;
1301
1302       Interrupt_Management.Initialize;
1303
1304       --  Prepare the set of signals that should unblocked in all tasks
1305
1306       Result := sigemptyset (Unblocked_Signal_Mask'Access);
1307       pragma Assert (Result = 0);
1308
1309       for J in Interrupt_Management.Interrupt_ID loop
1310          if System.Interrupt_Management.Keep_Unmasked (J) then
1311             Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
1312             pragma Assert (Result = 0);
1313          end if;
1314       end loop;
1315
1316       --  Initialize the lock used to synchronize chain of all ATCBs.
1317
1318       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1319
1320       Specific.Initialize (Environment_Task);
1321
1322       Enter_Task (Environment_Task);
1323
1324       --  Install the abort-signal handler
1325
1326       if State (System.Interrupt_Management.Abort_Task_Interrupt)
1327         /= Default
1328       then
1329          act.sa_flags := 0;
1330          act.sa_handler := Abort_Handler'Address;
1331
1332          Result := sigemptyset (Tmp_Set'Access);
1333          pragma Assert (Result = 0);
1334          act.sa_mask := Tmp_Set;
1335
1336          Result :=
1337            sigaction
1338            (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
1339             act'Unchecked_Access,
1340             old_act'Unchecked_Access);
1341          pragma Assert (Result = 0);
1342       end if;
1343    end Initialize;
1344
1345 end System.Task_Primitives.Operations;