OSDN Git Service

838f54e76f95a50f61ae414c43a1b056da3b6f97
[pf3gnuchains/gcc-fork.git] / gcc / ada / s-taprop-hpux-dce.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-2006, 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 HP-UX DCE threads (HPUX 10) 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 System.Interrupt_Management;
47 --  used for Keep_Unmasked
48 --           Abort_Task_Interrupt
49 --           Interrupt_ID
50
51 pragma Warnings (Off);
52 with System.Interrupt_Management.Operations;
53 --  used for Set_Interrupt_Mask
54 --           All_Tasks_Mask
55 pragma Elaborate_All (System.Interrupt_Management.Operations);
56
57 pragma Warnings (On);
58
59 with System.OS_Primitives;
60 --  used for Delay_Modes
61
62 with Interfaces.C;
63 --  used for int
64 --           size_t
65
66 with System.Parameters;
67 --  used for Size_Type
68
69 with System.Task_Primitives.Interrupt_Operations;
70 --  used for Get_Interrupt_ID
71
72 with System.Soft_Links;
73 --  used for Defer/Undefer_Abort
74
75 --  We use System.Soft_Links instead of System.Tasking.Initialization
76 --  because the later is a higher level package that we shouldn't depend on.
77 --  For example when using the restricted run time, it is replaced by
78 --  System.Tasking.Restricted.Stages.
79
80 with Unchecked_Conversion;
81 with Unchecked_Deallocation;
82
83 package body System.Task_Primitives.Operations is
84
85    package SSL renames System.Soft_Links;
86
87    use System.Tasking.Debug;
88    use System.Tasking;
89    use Interfaces.C;
90    use System.OS_Interface;
91    use System.Parameters;
92    use System.OS_Primitives;
93
94    package PIO renames System.Task_Primitives.Interrupt_Operations;
95
96    ----------------
97    -- Local Data --
98    ----------------
99
100    --  The followings are logically constants, but need to be initialized
101    --  at run time.
102
103    Single_RTS_Lock : aliased RTS_Lock;
104    --  This is a lock to allow only one thread of control in the RTS at
105    --  a time; it is used to execute in mutual exclusion from all other tasks.
106    --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
107
108    ATCB_Key : aliased pthread_key_t;
109    --  Key used to find the Ada Task_Id associated with a thread
110
111    Environment_Task_Id : Task_Id;
112    --  A variable to hold Task_Id for the environment task
113
114    Unblocked_Signal_Mask : aliased sigset_t;
115    --  The set of signals that should unblocked in all tasks
116
117    Time_Slice_Val : Integer;
118    pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
119
120    Dispatching_Policy : Character;
121    pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
122
123    --  Note: the reason that Locking_Policy is not needed is that this
124    --  is not implemented for DCE threads. The HPUX 10 port is at this
125    --  stage considered dead, and no further work is planned on it.
126
127    Foreign_Task_Elaborated : aliased Boolean := True;
128    --  Used to identified fake tasks (i.e., non-Ada Threads)
129
130    --------------------
131    -- Local Packages --
132    --------------------
133
134    package Specific is
135
136       procedure Initialize (Environment_Task : Task_Id);
137       pragma Inline (Initialize);
138       --  Initialize various data needed by this package
139
140       function Is_Valid_Task return Boolean;
141       pragma Inline (Is_Valid_Task);
142       --  Does the executing thread have a TCB?
143
144       procedure Set (Self_Id : Task_Id);
145       pragma Inline (Set);
146       --  Set the self id for the current task
147
148       function Self return Task_Id;
149       pragma Inline (Self);
150       --  Return a pointer to the Ada Task Control Block of the calling task
151
152    end Specific;
153
154    package body Specific is separate;
155    --  The body of this package is target specific
156
157    ---------------------------------
158    -- Support for foreign threads --
159    ---------------------------------
160
161    function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
162    --  Allocate and Initialize a new ATCB for the current Thread
163
164    function Register_Foreign_Thread
165      (Thread : Thread_Id) return Task_Id is separate;
166
167    -----------------------
168    -- Local Subprograms --
169    -----------------------
170
171    procedure Abort_Handler (Sig : Signal);
172
173    function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
174
175    -------------------
176    -- Abort_Handler --
177    -------------------
178
179    procedure Abort_Handler (Sig : Signal) is
180       pragma Unreferenced (Sig);
181
182       Self_Id : constant Task_Id := Self;
183       Result  : Interfaces.C.int;
184       Old_Set : aliased sigset_t;
185
186    begin
187       if Self_Id.Deferral_Level = 0
188         and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level and then
189         not Self_Id.Aborting
190       then
191          Self_Id.Aborting := True;
192
193          --  Make sure signals used for RTS internal purpose are unmasked
194
195          Result := pthread_sigmask (SIG_UNBLOCK,
196            Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
197          pragma Assert (Result = 0);
198
199          raise Standard'Abort_Signal;
200       end if;
201    end Abort_Handler;
202
203    -----------------
204    -- Stack_Guard --
205    -----------------
206
207    --  The underlying thread system sets a guard page at the
208    --  bottom of a thread stack, so nothing is needed.
209    --  ??? Check the comment above
210
211    procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
212       pragma Unreferenced (T, On);
213    begin
214       null;
215    end Stack_Guard;
216
217    -------------------
218    -- Get_Thread_Id --
219    -------------------
220
221    function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
222    begin
223       return T.Common.LL.Thread;
224    end Get_Thread_Id;
225
226    ----------
227    -- Self --
228    ----------
229
230    function Self return Task_Id renames Specific.Self;
231
232    ---------------------
233    -- Initialize_Lock --
234    ---------------------
235
236    --  Note: mutexes and cond_variables needed per-task basis are
237    --        initialized in Initialize_TCB and the Storage_Error is
238    --        handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
239    --        used in RTS is initialized before any status change of RTS.
240    --        Therefore rasing Storage_Error in the following routines
241    --        should be able to be handled safely.
242
243    procedure Initialize_Lock
244      (Prio : System.Any_Priority;
245       L    : access Lock)
246    is
247       Attributes : aliased pthread_mutexattr_t;
248       Result     : Interfaces.C.int;
249
250    begin
251       Result := pthread_mutexattr_init (Attributes'Access);
252       pragma Assert (Result = 0 or else Result = ENOMEM);
253
254       if Result = ENOMEM then
255          raise Storage_Error;
256       end if;
257
258       L.Priority := Prio;
259
260       Result := pthread_mutex_init (L.L'Access, Attributes'Access);
261       pragma Assert (Result = 0 or else Result = ENOMEM);
262
263       if Result = ENOMEM then
264          raise Storage_Error;
265       end if;
266
267       Result := pthread_mutexattr_destroy (Attributes'Access);
268       pragma Assert (Result = 0);
269    end Initialize_Lock;
270
271    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
272       pragma Unreferenced (Level);
273
274       Attributes : aliased pthread_mutexattr_t;
275       Result     : Interfaces.C.int;
276
277    begin
278       Result := pthread_mutexattr_init (Attributes'Access);
279       pragma Assert (Result = 0 or else Result = ENOMEM);
280
281       if Result = ENOMEM then
282          raise Storage_Error;
283       end if;
284
285       Result := pthread_mutex_init (L, Attributes'Access);
286
287       pragma Assert (Result = 0 or else Result = ENOMEM);
288
289       if Result = ENOMEM then
290          raise Storage_Error;
291       end if;
292
293       Result := pthread_mutexattr_destroy (Attributes'Access);
294       pragma Assert (Result = 0);
295    end Initialize_Lock;
296
297    -------------------
298    -- Finalize_Lock --
299    -------------------
300
301    procedure Finalize_Lock (L : access Lock) is
302       Result : Interfaces.C.int;
303    begin
304       Result := pthread_mutex_destroy (L.L'Access);
305       pragma Assert (Result = 0);
306    end Finalize_Lock;
307
308    procedure Finalize_Lock (L : access RTS_Lock) is
309       Result : Interfaces.C.int;
310    begin
311       Result := pthread_mutex_destroy (L);
312       pragma Assert (Result = 0);
313    end Finalize_Lock;
314
315    ----------------
316    -- Write_Lock --
317    ----------------
318
319    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
320       Result : Interfaces.C.int;
321
322    begin
323       L.Owner_Priority := Get_Priority (Self);
324
325       if L.Priority < L.Owner_Priority then
326          Ceiling_Violation := True;
327          return;
328       end if;
329
330       Result := pthread_mutex_lock (L.L'Access);
331       pragma Assert (Result = 0);
332       Ceiling_Violation := False;
333    end Write_Lock;
334
335    procedure Write_Lock
336      (L : access RTS_Lock; Global_Lock : Boolean := False)
337    is
338       Result : Interfaces.C.int;
339    begin
340       if not Single_Lock or else Global_Lock then
341          Result := pthread_mutex_lock (L);
342          pragma Assert (Result = 0);
343       end if;
344    end Write_Lock;
345
346    procedure Write_Lock (T : Task_Id) is
347       Result : Interfaces.C.int;
348    begin
349       if not Single_Lock then
350          Result := pthread_mutex_lock (T.Common.LL.L'Access);
351          pragma Assert (Result = 0);
352       end if;
353    end Write_Lock;
354
355    ---------------
356    -- Read_Lock --
357    ---------------
358
359    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
360    begin
361       Write_Lock (L, Ceiling_Violation);
362    end Read_Lock;
363
364    ------------
365    -- Unlock --
366    ------------
367
368    procedure Unlock (L : access Lock) is
369       Result : Interfaces.C.int;
370    begin
371       Result := pthread_mutex_unlock (L.L'Access);
372       pragma Assert (Result = 0);
373    end Unlock;
374
375    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
376       Result : Interfaces.C.int;
377    begin
378       if not Single_Lock or else Global_Lock then
379          Result := pthread_mutex_unlock (L);
380          pragma Assert (Result = 0);
381       end if;
382    end Unlock;
383
384    procedure Unlock (T : Task_Id) is
385       Result : Interfaces.C.int;
386    begin
387       if not Single_Lock then
388          Result := pthread_mutex_unlock (T.Common.LL.L'Access);
389          pragma Assert (Result = 0);
390       end if;
391    end Unlock;
392
393    -----------
394    -- Sleep --
395    -----------
396
397    procedure Sleep
398      (Self_ID : Task_Id;
399       Reason  : System.Tasking.Task_States)
400    is
401       pragma Unreferenced (Reason);
402
403       Result : Interfaces.C.int;
404    begin
405       if Single_Lock then
406          Result := pthread_cond_wait
407            (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
408       else
409          Result := pthread_cond_wait
410            (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
411       end if;
412
413       --  EINTR is not considered a failure
414
415       pragma Assert (Result = 0 or else Result = EINTR);
416    end Sleep;
417
418    -----------------
419    -- Timed_Sleep --
420    -----------------
421
422    procedure Timed_Sleep
423      (Self_ID  : Task_Id;
424       Time     : Duration;
425       Mode     : ST.Delay_Modes;
426       Reason   : System.Tasking.Task_States;
427       Timedout : out Boolean;
428       Yielded  : out Boolean)
429    is
430       pragma Unreferenced (Reason);
431
432       Check_Time : constant Duration := Monotonic_Clock;
433       Abs_Time   : Duration;
434       Request    : aliased timespec;
435       Result     : Interfaces.C.int;
436
437    begin
438       Timedout := True;
439       Yielded := False;
440
441       if Mode = Relative then
442          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
443       else
444          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
445       end if;
446
447       if Abs_Time > Check_Time then
448          Request := To_Timespec (Abs_Time);
449
450          loop
451             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
452               or else Self_ID.Pending_Priority_Change;
453
454             if Single_Lock then
455                Result := pthread_cond_timedwait
456                  (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
457                   Request'Access);
458
459             else
460                Result := pthread_cond_timedwait
461                  (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
462                   Request'Access);
463             end if;
464
465             exit when Abs_Time <= Monotonic_Clock;
466
467             if Result = 0 or Result = EINTR then
468
469                --  Somebody may have called Wakeup for us
470
471                Timedout := False;
472                exit;
473             end if;
474
475             pragma Assert (Result = ETIMEDOUT);
476          end loop;
477       end if;
478    end Timed_Sleep;
479
480    -----------------
481    -- Timed_Delay --
482    -----------------
483
484    procedure Timed_Delay
485      (Self_ID  : Task_Id;
486       Time     : Duration;
487       Mode     : ST.Delay_Modes)
488    is
489       Check_Time : constant Duration := Monotonic_Clock;
490       Abs_Time   : Duration;
491       Request    : aliased timespec;
492       Result     : Interfaces.C.int;
493
494    begin
495       if Single_Lock then
496          Lock_RTS;
497       end if;
498
499       Write_Lock (Self_ID);
500
501       if Mode = Relative then
502          Abs_Time := Time + Check_Time;
503       else
504          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
505       end if;
506
507       if Abs_Time > Check_Time then
508          Request := To_Timespec (Abs_Time);
509          Self_ID.Common.State := Delay_Sleep;
510
511          loop
512             if Self_ID.Pending_Priority_Change then
513                Self_ID.Pending_Priority_Change := False;
514                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
515                Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
516             end if;
517
518             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
519
520             if Single_Lock then
521                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
522                  Single_RTS_Lock'Access, Request'Access);
523             else
524                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
525                  Self_ID.Common.LL.L'Access, Request'Access);
526             end if;
527
528             exit when Abs_Time <= Monotonic_Clock;
529
530             pragma Assert (Result = 0 or else
531               Result = ETIMEDOUT or else
532               Result = EINTR);
533          end loop;
534
535          Self_ID.Common.State := Runnable;
536       end if;
537
538       Unlock (Self_ID);
539
540       if Single_Lock then
541          Unlock_RTS;
542       end if;
543
544       Result := sched_yield;
545    end Timed_Delay;
546
547    ---------------------
548    -- Monotonic_Clock --
549    ---------------------
550
551    function Monotonic_Clock return Duration is
552       TS     : aliased timespec;
553       Result : Interfaces.C.int;
554    begin
555       Result := Clock_Gettime (CLOCK_REALTIME, TS'Unchecked_Access);
556       pragma Assert (Result = 0);
557       return To_Duration (TS);
558    end Monotonic_Clock;
559
560    -------------------
561    -- RT_Resolution --
562    -------------------
563
564    function RT_Resolution return Duration is
565    begin
566       return 10#1.0#E-6;
567    end RT_Resolution;
568
569    ------------
570    -- Wakeup --
571    ------------
572
573    procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
574       pragma Unreferenced (Reason);
575
576       Result : Interfaces.C.int;
577
578    begin
579       Result := pthread_cond_signal (T.Common.LL.CV'Access);
580       pragma Assert (Result = 0);
581    end Wakeup;
582
583    -----------
584    -- Yield --
585    -----------
586
587    procedure Yield (Do_Yield : Boolean := True) is
588       Result : Interfaces.C.int;
589       pragma Unreferenced (Result);
590    begin
591       if Do_Yield then
592          Result := sched_yield;
593       end if;
594    end Yield;
595
596    ------------------
597    -- Set_Priority --
598    ------------------
599
600    type Prio_Array_Type is array (System.Any_Priority) of Integer;
601    pragma Atomic_Components (Prio_Array_Type);
602
603    Prio_Array : Prio_Array_Type;
604    --  Global array containing the id of the currently running task for
605    --  each priority.
606    --
607    --  Note: we assume that we are on a single processor with run-til-blocked
608    --  scheduling.
609
610    procedure Set_Priority
611      (T                   : Task_Id;
612       Prio                : System.Any_Priority;
613       Loss_Of_Inheritance : Boolean := False)
614    is
615       Result     : Interfaces.C.int;
616       Array_Item : Integer;
617       Param      : aliased struct_sched_param;
618
619    begin
620       Param.sched_priority  := Interfaces.C.int (Underlying_Priorities (Prio));
621
622       if Time_Slice_Val > 0 then
623          Result := pthread_setschedparam
624            (T.Common.LL.Thread, SCHED_RR, Param'Access);
625
626       elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
627          Result := pthread_setschedparam
628            (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
629
630       else
631          Result := pthread_setschedparam
632            (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
633       end if;
634
635       pragma Assert (Result = 0);
636
637       if Dispatching_Policy = 'F' then
638
639          --  Annex D requirement [RM D.2.2 par. 9]:
640          --    If the task drops its priority due to the loss of inherited
641          --    priority, it is added at the head of the ready queue for its
642          --    new active priority.
643
644          if Loss_Of_Inheritance
645            and then Prio < T.Common.Current_Priority
646          then
647             Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
648             Prio_Array (T.Common.Base_Priority) := Array_Item;
649
650             loop
651                --  Let some processes a chance to arrive
652
653                Yield;
654
655                --  Then wait for our turn to proceed
656
657                exit when Array_Item = Prio_Array (T.Common.Base_Priority)
658                  or else Prio_Array (T.Common.Base_Priority) = 1;
659             end loop;
660
661             Prio_Array (T.Common.Base_Priority) :=
662               Prio_Array (T.Common.Base_Priority) - 1;
663          end if;
664       end if;
665
666       T.Common.Current_Priority := Prio;
667    end Set_Priority;
668
669    ------------------
670    -- Get_Priority --
671    ------------------
672
673    function Get_Priority (T : Task_Id) return System.Any_Priority is
674    begin
675       return T.Common.Current_Priority;
676    end Get_Priority;
677
678    ----------------
679    -- Enter_Task --
680    ----------------
681
682    procedure Enter_Task (Self_ID : Task_Id) is
683    begin
684       Self_ID.Common.LL.Thread := pthread_self;
685       Specific.Set (Self_ID);
686
687       Lock_RTS;
688
689       for J in Known_Tasks'Range loop
690          if Known_Tasks (J) = null then
691             Known_Tasks (J) := Self_ID;
692             Self_ID.Known_Tasks_Index := J;
693             exit;
694          end if;
695       end loop;
696
697       Unlock_RTS;
698    end Enter_Task;
699
700    --------------
701    -- New_ATCB --
702    --------------
703
704    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
705    begin
706       return new Ada_Task_Control_Block (Entry_Num);
707    end New_ATCB;
708
709    -------------------
710    -- Is_Valid_Task --
711    -------------------
712
713    function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
714
715    -----------------------------
716    -- Register_Foreign_Thread --
717    -----------------------------
718
719    function Register_Foreign_Thread return Task_Id is
720    begin
721       if Is_Valid_Task then
722          return Self;
723       else
724          return Register_Foreign_Thread (pthread_self);
725       end if;
726    end Register_Foreign_Thread;
727
728    --------------------
729    -- Initialize_TCB --
730    --------------------
731
732    procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
733       Mutex_Attr : aliased pthread_mutexattr_t;
734       Result     : Interfaces.C.int;
735       Cond_Attr  : aliased pthread_condattr_t;
736
737    begin
738       if not Single_Lock then
739          Result := pthread_mutexattr_init (Mutex_Attr'Access);
740          pragma Assert (Result = 0 or else Result = ENOMEM);
741
742          if Result = 0 then
743             Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
744               Mutex_Attr'Access);
745             pragma Assert (Result = 0 or else Result = ENOMEM);
746          end if;
747
748          if Result /= 0 then
749             Succeeded := False;
750             return;
751          end if;
752
753          Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
754          pragma Assert (Result = 0);
755       end if;
756
757       Result := pthread_condattr_init (Cond_Attr'Access);
758       pragma Assert (Result = 0 or else Result = ENOMEM);
759
760       if Result = 0 then
761          Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
762            Cond_Attr'Access);
763          pragma Assert (Result = 0 or else Result = ENOMEM);
764       end if;
765
766       if Result = 0 then
767          Succeeded := True;
768       else
769          if not Single_Lock then
770             Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
771             pragma Assert (Result = 0);
772          end if;
773
774          Succeeded := False;
775       end if;
776
777       Result := pthread_condattr_destroy (Cond_Attr'Access);
778       pragma Assert (Result = 0);
779    end Initialize_TCB;
780
781    -----------------
782    -- Create_Task --
783    -----------------
784
785    procedure Create_Task
786      (T          : Task_Id;
787       Wrapper    : System.Address;
788       Stack_Size : System.Parameters.Size_Type;
789       Priority   : System.Any_Priority;
790       Succeeded  : out Boolean)
791    is
792       Attributes : aliased pthread_attr_t;
793       Result     : Interfaces.C.int;
794
795       function Thread_Body_Access is new
796         Unchecked_Conversion (System.Address, Thread_Body);
797
798    begin
799       Result := pthread_attr_init (Attributes'Access);
800       pragma Assert (Result = 0 or else Result = ENOMEM);
801
802       if Result /= 0 then
803          Succeeded := False;
804          return;
805       end if;
806
807       Result := pthread_attr_setstacksize
808         (Attributes'Access, Interfaces.C.size_t (Stack_Size));
809       pragma Assert (Result = 0);
810
811       --  Since the initial signal mask of a thread is inherited from the
812       --  creator, and the Environment task has all its signals masked, we
813       --  do not need to manipulate caller's signal mask at this point.
814       --  All tasks in RTS will have All_Tasks_Mask initially.
815
816       Result := pthread_create
817         (T.Common.LL.Thread'Access,
818          Attributes'Access,
819          Thread_Body_Access (Wrapper),
820          To_Address (T));
821       pragma Assert (Result = 0 or else Result = EAGAIN);
822
823       Succeeded := Result = 0;
824
825       pthread_detach (T.Common.LL.Thread'Access);
826       --  Detach the thread using pthread_detach, sinc DCE threads do not have
827       --  pthread_attr_set_detachstate.
828
829       Result := pthread_attr_destroy (Attributes'Access);
830       pragma Assert (Result = 0);
831
832       Set_Priority (T, Priority);
833    end Create_Task;
834
835    ------------------
836    -- Finalize_TCB --
837    ------------------
838
839    procedure Finalize_TCB (T : Task_Id) is
840       Result  : Interfaces.C.int;
841       Tmp     : Task_Id := T;
842       Is_Self : constant Boolean := T = Self;
843
844       procedure Free is new
845         Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
846
847    begin
848       if not Single_Lock then
849          Result := pthread_mutex_destroy (T.Common.LL.L'Access);
850          pragma Assert (Result = 0);
851       end if;
852
853       Result := pthread_cond_destroy (T.Common.LL.CV'Access);
854       pragma Assert (Result = 0);
855
856       if T.Known_Tasks_Index /= -1 then
857          Known_Tasks (T.Known_Tasks_Index) := null;
858       end if;
859
860       Free (Tmp);
861
862       if Is_Self then
863          Specific.Set (null);
864       end if;
865    end Finalize_TCB;
866
867    ---------------
868    -- Exit_Task --
869    ---------------
870
871    procedure Exit_Task is
872    begin
873       Specific.Set (null);
874    end Exit_Task;
875
876    ----------------
877    -- Abort_Task --
878    ----------------
879
880    procedure Abort_Task (T : Task_Id) is
881    begin
882       --
883       --  Interrupt Server_Tasks may be waiting on an "event" flag (signal)
884       --
885       if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then
886          System.Interrupt_Management.Operations.Interrupt_Self_Process
887            (System.Interrupt_Management.Interrupt_ID
888              (PIO.Get_Interrupt_ID (T)));
889       end if;
890    end Abort_Task;
891
892    ----------------
893    -- Initialize --
894    ----------------
895
896    procedure Initialize (S : in out Suspension_Object) is
897       Mutex_Attr : aliased pthread_mutexattr_t;
898       Cond_Attr  : aliased pthread_condattr_t;
899       Result     : Interfaces.C.int;
900    begin
901       --  Initialize internal state. It is always initialized to False (ARM
902       --  D.10 par. 6).
903
904       S.State := False;
905       S.Waiting := False;
906
907       --  Initialize internal mutex
908
909       Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
910       pragma Assert (Result = 0 or else Result = ENOMEM);
911
912       if Result = ENOMEM then
913          raise Storage_Error;
914       end if;
915
916       --  Initialize internal condition variable
917
918       Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
919       pragma Assert (Result = 0 or else Result = ENOMEM);
920
921       if Result /= 0 then
922          Result := pthread_mutex_destroy (S.L'Access);
923          pragma Assert (Result = 0);
924
925          if Result = ENOMEM then
926             raise Storage_Error;
927          end if;
928       end if;
929    end Initialize;
930
931    --------------
932    -- Finalize --
933    --------------
934
935    procedure Finalize (S : in out Suspension_Object) is
936       Result  : Interfaces.C.int;
937    begin
938       --  Destroy internal mutex
939
940       Result := pthread_mutex_destroy (S.L'Access);
941       pragma Assert (Result = 0);
942
943       --  Destroy internal condition variable
944
945       Result := pthread_cond_destroy (S.CV'Access);
946       pragma Assert (Result = 0);
947    end Finalize;
948
949    -------------------
950    -- Current_State --
951    -------------------
952
953    function Current_State (S : Suspension_Object) return Boolean is
954    begin
955       --  We do not want to use lock on this read operation. State is marked
956       --  as Atomic so that we ensure that the value retrieved is correct.
957
958       return S.State;
959    end Current_State;
960
961    ---------------
962    -- Set_False --
963    ---------------
964
965    procedure Set_False (S : in out Suspension_Object) is
966       Result  : Interfaces.C.int;
967    begin
968       SSL.Abort_Defer.all;
969
970       Result := pthread_mutex_lock (S.L'Access);
971       pragma Assert (Result = 0);
972
973       S.State := False;
974
975       Result := pthread_mutex_unlock (S.L'Access);
976       pragma Assert (Result = 0);
977
978       SSL.Abort_Undefer.all;
979    end Set_False;
980
981    --------------
982    -- Set_True --
983    --------------
984
985    procedure Set_True (S : in out Suspension_Object) is
986       Result : Interfaces.C.int;
987    begin
988       SSL.Abort_Defer.all;
989
990       Result := pthread_mutex_lock (S.L'Access);
991       pragma Assert (Result = 0);
992
993       --  If there is already a task waiting on this suspension object then
994       --  we resume it, leaving the state of the suspension object to False,
995       --  as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
996       --  the state to True.
997
998       if S.Waiting then
999          S.Waiting := False;
1000          S.State := False;
1001
1002          Result := pthread_cond_signal (S.CV'Access);
1003          pragma Assert (Result = 0);
1004       else
1005          S.State := True;
1006       end if;
1007
1008       Result := pthread_mutex_unlock (S.L'Access);
1009       pragma Assert (Result = 0);
1010
1011       SSL.Abort_Undefer.all;
1012    end Set_True;
1013
1014    ------------------------
1015    -- Suspend_Until_True --
1016    ------------------------
1017
1018    procedure Suspend_Until_True (S : in out Suspension_Object) is
1019       Result : Interfaces.C.int;
1020    begin
1021       SSL.Abort_Defer.all;
1022
1023       Result := pthread_mutex_lock (S.L'Access);
1024       pragma Assert (Result = 0);
1025
1026       if S.Waiting then
1027          --  Program_Error must be raised upon calling Suspend_Until_True
1028          --  if another task is already waiting on that suspension object
1029          --  (ARM D.10 par. 10).
1030
1031          Result := pthread_mutex_unlock (S.L'Access);
1032          pragma Assert (Result = 0);
1033
1034          SSL.Abort_Undefer.all;
1035
1036          raise Program_Error;
1037       else
1038          --  Suspend the task if the state is False. Otherwise, the task
1039          --  continues its execution, and the state of the suspension object
1040          --  is set to False (ARM D.10 par. 9).
1041
1042          if S.State then
1043             S.State := False;
1044          else
1045             S.Waiting := True;
1046             Result := pthread_cond_wait (S.CV'Access, S.L'Access);
1047          end if;
1048
1049          Result := pthread_mutex_unlock (S.L'Access);
1050          pragma Assert (Result = 0);
1051
1052          SSL.Abort_Undefer.all;
1053       end if;
1054    end Suspend_Until_True;
1055
1056    ----------------
1057    -- Check_Exit --
1058    ----------------
1059
1060    --  Dummy version
1061
1062    function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1063       pragma Unreferenced (Self_ID);
1064    begin
1065       return True;
1066    end Check_Exit;
1067
1068    --------------------
1069    -- Check_No_Locks --
1070    --------------------
1071
1072    function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1073       pragma Unreferenced (Self_ID);
1074    begin
1075       return True;
1076    end Check_No_Locks;
1077
1078    ----------------------
1079    -- Environment_Task --
1080    ----------------------
1081
1082    function Environment_Task return Task_Id is
1083    begin
1084       return Environment_Task_Id;
1085    end Environment_Task;
1086
1087    --------------
1088    -- Lock_RTS --
1089    --------------
1090
1091    procedure Lock_RTS is
1092    begin
1093       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1094    end Lock_RTS;
1095
1096    ----------------
1097    -- Unlock_RTS --
1098    ----------------
1099
1100    procedure Unlock_RTS is
1101    begin
1102       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1103    end Unlock_RTS;
1104
1105    ------------------
1106    -- Suspend_Task --
1107    ------------------
1108
1109    function Suspend_Task
1110      (T           : ST.Task_Id;
1111       Thread_Self : Thread_Id) return Boolean
1112    is
1113       pragma Unreferenced (T);
1114       pragma Unreferenced (Thread_Self);
1115    begin
1116       return False;
1117    end Suspend_Task;
1118
1119    -----------------
1120    -- Resume_Task --
1121    -----------------
1122
1123    function Resume_Task
1124      (T           : ST.Task_Id;
1125       Thread_Self : Thread_Id) return Boolean
1126    is
1127       pragma Unreferenced (T);
1128       pragma Unreferenced (Thread_Self);
1129    begin
1130       return False;
1131    end Resume_Task;
1132
1133    ----------------
1134    -- Initialize --
1135    ----------------
1136
1137    procedure Initialize (Environment_Task : Task_Id) is
1138       act       : aliased struct_sigaction;
1139       old_act   : aliased struct_sigaction;
1140       Tmp_Set   : aliased sigset_t;
1141       Result    : Interfaces.C.int;
1142
1143       function State
1144         (Int : System.Interrupt_Management.Interrupt_ID) return Character;
1145       pragma Import (C, State, "__gnat_get_interrupt_state");
1146       --  Get interrupt state. Defined in a-init.c. The input argument is
1147       --  the interrupt number, and the result is one of the following:
1148
1149       Default : constant Character := 's';
1150       --    'n'   this interrupt not set by any Interrupt_State pragma
1151       --    'u'   Interrupt_State pragma set state to User
1152       --    'r'   Interrupt_State pragma set state to Runtime
1153       --    's'   Interrupt_State pragma set state to System (use "default"
1154       --           system handler)
1155
1156    begin
1157       Environment_Task_Id := Environment_Task;
1158
1159       Interrupt_Management.Initialize;
1160
1161       --  Initialize the lock used to synchronize chain of all ATCBs
1162
1163       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1164
1165       Specific.Initialize (Environment_Task);
1166
1167       Enter_Task (Environment_Task);
1168
1169       --  Install the abort-signal handler
1170
1171       if State (System.Interrupt_Management.Abort_Task_Interrupt)
1172                                                      /= Default
1173       then
1174          act.sa_flags := 0;
1175          act.sa_handler := Abort_Handler'Address;
1176
1177          Result := sigemptyset (Tmp_Set'Access);
1178          pragma Assert (Result = 0);
1179          act.sa_mask := Tmp_Set;
1180
1181          Result :=
1182            sigaction (
1183              Signal (System.Interrupt_Management.Abort_Task_Interrupt),
1184              act'Unchecked_Access,
1185              old_act'Unchecked_Access);
1186          pragma Assert (Result = 0);
1187       end if;
1188    end Initialize;
1189
1190    --  NOTE: Unlike other pthread implementations, we do *not* mask all
1191    --  signals here since we handle signals using the process-wide primitive
1192    --  signal, rather than using sigthreadmask and sigwait. The reason of
1193    --  this difference is that sigwait doesn't work when some critical
1194    --  signals (SIGABRT, SIGPIPE) are masked.
1195
1196 end System.Task_Primitives.Operations;