1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
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 --
9 -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
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. --
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. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
34 -- This is a IRIX (pthread library) version of this package
36 -- This package contains all the GNULL primitives that interface directly
37 -- with the underlying OS.
40 -- Turn off polling, we do not want ATC polling to take place during
41 -- tasking operations. It causes infinite loops and other problems.
47 with System
.Task_Info
;
49 with System
.Tasking
.Debug
;
50 -- used for Known_Tasks
52 with System
.Interrupt_Management
;
53 -- used for Keep_Unmasked
54 -- Abort_Task_Interrupt
57 with System
.OS_Primitives
;
58 -- used for Delay_Modes
63 with System
.Soft_Links
;
64 -- used for Abort_Defer/Undefer
66 -- We use System.Soft_Links instead of System.Tasking.Initialization
67 -- because the later is a higher level package that we shouldn't depend on.
68 -- For example when using the restricted run time, it is replaced by
69 -- System.Tasking.Restricted.Stages.
71 with Unchecked_Conversion
;
72 with Unchecked_Deallocation
;
74 package body System
.Task_Primitives
.Operations
is
76 package SSL
renames System
.Soft_Links
;
79 use System
.Tasking
.Debug
;
81 use System
.OS_Interface
;
82 use System
.OS_Primitives
;
83 use System
.Parameters
;
89 -- The followings are logically constants, but need to be initialized
92 Single_RTS_Lock
: aliased RTS_Lock
;
93 -- This is a lock to allow only one thread of control in the RTS at
94 -- a time; it is used to execute in mutual exclusion from all other tasks.
95 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
97 ATCB_Key
: aliased pthread_key_t
;
98 -- Key used to find the Ada Task_Id associated with a thread
100 Environment_Task_Id
: Task_Id
;
101 -- A variable to hold Task_Id for the environment task
103 Locking_Policy
: Character;
104 pragma Import
(C
, Locking_Policy
, "__gl_locking_policy");
106 Real_Time_Clock_Id
: constant clockid_t
:= CLOCK_REALTIME
;
108 Unblocked_Signal_Mask
: aliased sigset_t
;
110 Foreign_Task_Elaborated
: aliased Boolean := True;
111 -- Used to identified fake tasks (i.e., non-Ada Threads)
119 procedure Initialize
(Environment_Task
: Task_Id
);
120 pragma Inline
(Initialize
);
121 -- Initialize various data needed by this package
123 function Is_Valid_Task
return Boolean;
124 pragma Inline
(Is_Valid_Task
);
125 -- Does executing thread have a TCB?
127 procedure Set
(Self_Id
: Task_Id
);
129 -- Set the self id for the current task
131 function Self
return Task_Id
;
132 pragma Inline
(Self
);
133 -- Return a pointer to the Ada Task Control Block of the calling task
137 package body Specific
is separate;
138 -- The body of this package is target specific
140 ---------------------------------
141 -- Support for foreign threads --
142 ---------------------------------
144 function Register_Foreign_Thread
(Thread
: Thread_Id
) return Task_Id
;
145 -- Allocate and Initialize a new ATCB for the current Thread
147 function Register_Foreign_Thread
148 (Thread
: Thread_Id
) return Task_Id
is separate;
150 -----------------------
151 -- Local Subprograms --
152 -----------------------
154 function To_Address
is new Unchecked_Conversion
(Task_Id
, System
.Address
);
156 procedure Abort_Handler
(Sig
: Signal
);
157 -- Signal handler used to implement asynchronous abort
163 procedure Abort_Handler
(Sig
: Signal
) is
164 pragma Unreferenced
(Sig
);
166 T
: constant Task_Id
:= Self
;
167 Result
: Interfaces
.C
.int
;
168 Old_Set
: aliased sigset_t
;
171 -- It is not safe to raise an exception when using ZCX and the GCC
172 -- exception handling mechanism.
174 if ZCX_By_Default
and then GCC_ZCX_Support
then
178 if T
.Deferral_Level
= 0
179 and then T
.Pending_ATC_Level
< T
.ATC_Nesting_Level
181 -- Make sure signals used for RTS internal purpose are unmasked
183 Result
:= pthread_sigmask
185 Unblocked_Signal_Mask
'Unchecked_Access,
186 Old_Set
'Unchecked_Access);
187 pragma Assert
(Result
= 0);
189 raise Standard
'Abort_Signal;
197 -- The underlying thread system sets a guard page at the
198 -- bottom of a thread stack, so nothing is needed.
200 procedure Stack_Guard
(T
: ST
.Task_Id
; On
: Boolean) is
201 pragma Unreferenced
(On
);
202 pragma Unreferenced
(T
);
211 function Get_Thread_Id
(T
: ST
.Task_Id
) return OSI
.Thread_Id
is
213 return T
.Common
.LL
.Thread
;
220 function Self
return Task_Id
renames Specific
.Self
;
222 ---------------------
223 -- Initialize_Lock --
224 ---------------------
226 -- Note: mutexes and cond_variables needed per-task basis are
227 -- initialized in Initialize_TCB and the Storage_Error is
228 -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
229 -- used in RTS is initialized before any status change of RTS.
230 -- Therefore rasing Storage_Error in the following routines
231 -- should be able to be handled safely.
233 procedure Initialize_Lock
234 (Prio
: System
.Any_Priority
;
237 Attributes
: aliased pthread_mutexattr_t
;
238 Result
: Interfaces
.C
.int
;
241 Result
:= pthread_mutexattr_init
(Attributes
'Access);
242 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
244 if Result
= ENOMEM
then
248 if Locking_Policy
= 'C' then
249 Result
:= pthread_mutexattr_setprotocol
250 (Attributes
'Access, PTHREAD_PRIO_PROTECT
);
251 pragma Assert
(Result
= 0);
253 Result
:= pthread_mutexattr_setprioceiling
254 (Attributes
'Access, Interfaces
.C
.int
(Prio
));
255 pragma Assert
(Result
= 0);
258 Result
:= pthread_mutex_init
(L
, Attributes
'Access);
259 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
261 if Result
= ENOMEM
then
262 Result
:= pthread_mutexattr_destroy
(Attributes
'Access);
266 Result
:= pthread_mutexattr_destroy
(Attributes
'Access);
267 pragma Assert
(Result
= 0);
270 procedure Initialize_Lock
(L
: access RTS_Lock
; Level
: Lock_Level
) is
271 pragma Unreferenced
(Level
);
273 Attributes
: aliased pthread_mutexattr_t
;
274 Result
: Interfaces
.C
.int
;
277 Result
:= pthread_mutexattr_init
(Attributes
'Access);
278 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
280 if Result
= ENOMEM
then
284 if Locking_Policy
= 'C' then
285 Result
:= pthread_mutexattr_setprotocol
286 (Attributes
'Access, PTHREAD_PRIO_PROTECT
);
287 pragma Assert
(Result
= 0);
289 Result
:= pthread_mutexattr_setprioceiling
290 (Attributes
'Access, Interfaces
.C
.int
(System
.Any_Priority
'Last));
291 pragma Assert
(Result
= 0);
294 Result
:= pthread_mutex_init
(L
, Attributes
'Access);
296 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
298 if Result
= ENOMEM
then
299 Result
:= pthread_mutexattr_destroy
(Attributes
'Access);
303 Result
:= pthread_mutexattr_destroy
(Attributes
'Access);
310 procedure Finalize_Lock
(L
: access Lock
) is
311 Result
: Interfaces
.C
.int
;
313 Result
:= pthread_mutex_destroy
(L
);
314 pragma Assert
(Result
= 0);
317 procedure Finalize_Lock
(L
: access RTS_Lock
) is
318 Result
: Interfaces
.C
.int
;
320 Result
:= pthread_mutex_destroy
(L
);
321 pragma Assert
(Result
= 0);
328 procedure Write_Lock
(L
: access Lock
; Ceiling_Violation
: out Boolean) is
329 Result
: Interfaces
.C
.int
;
331 Result
:= pthread_mutex_lock
(L
);
332 Ceiling_Violation
:= Result
= EINVAL
;
334 -- Assumes the cause of EINVAL is a priority ceiling violation
336 pragma Assert
(Result
= 0 or else Result
= EINVAL
);
340 (L
: access RTS_Lock
;
341 Global_Lock
: Boolean := False)
343 Result
: Interfaces
.C
.int
;
345 if not Single_Lock
or else Global_Lock
then
346 Result
:= pthread_mutex_lock
(L
);
347 pragma Assert
(Result
= 0);
351 procedure Write_Lock
(T
: Task_Id
) is
352 Result
: Interfaces
.C
.int
;
354 if not Single_Lock
then
355 Result
:= pthread_mutex_lock
(T
.Common
.LL
.L
'Access);
356 pragma Assert
(Result
= 0);
364 procedure Read_Lock
(L
: access Lock
; Ceiling_Violation
: out Boolean) is
366 Write_Lock
(L
, Ceiling_Violation
);
373 procedure Unlock
(L
: access Lock
) is
374 Result
: Interfaces
.C
.int
;
376 Result
:= pthread_mutex_unlock
(L
);
377 pragma Assert
(Result
= 0);
380 procedure Unlock
(L
: access RTS_Lock
; Global_Lock
: Boolean := False) is
381 Result
: Interfaces
.C
.int
;
384 if not Single_Lock
or else Global_Lock
then
385 Result
:= pthread_mutex_unlock
(L
);
386 pragma Assert
(Result
= 0);
390 procedure Unlock
(T
: Task_Id
) is
391 Result
: Interfaces
.C
.int
;
394 if not Single_Lock
then
395 Result
:= pthread_mutex_unlock
(T
.Common
.LL
.L
'Access);
396 pragma Assert
(Result
= 0);
405 (Self_ID
: ST
.Task_Id
;
406 Reason
: System
.Tasking
.Task_States
)
408 pragma Unreferenced
(Reason
);
410 Result
: Interfaces
.C
.int
;
414 Result
:= pthread_cond_wait
415 (Self_ID
.Common
.LL
.CV
'Access, Single_RTS_Lock
'Access);
417 Result
:= pthread_cond_wait
418 (Self_ID
.Common
.LL
.CV
'Access, Self_ID
.Common
.LL
.L
'Access);
421 -- EINTR is not considered a failure
423 pragma Assert
(Result
= 0 or else Result
= EINTR
);
430 procedure Timed_Sleep
433 Mode
: ST
.Delay_Modes
;
434 Reason
: Task_States
;
435 Timedout
: out Boolean;
436 Yielded
: out Boolean)
438 pragma Unreferenced
(Reason
);
440 Check_Time
: constant Duration := Monotonic_Clock
;
442 Request
: aliased timespec
;
443 Result
: Interfaces
.C
.int
;
449 if Mode
= Relative
then
450 Abs_Time
:= Duration'Min (Time
, Max_Sensible_Delay
) + Check_Time
;
452 Abs_Time
:= Duration'Min (Check_Time
+ Max_Sensible_Delay
, Time
);
455 if Abs_Time
> Check_Time
then
456 Request
:= To_Timespec
(Abs_Time
);
459 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
460 or else Self_ID
.Pending_Priority_Change
;
463 Result
:= pthread_cond_timedwait
464 (Self_ID
.Common
.LL
.CV
'Access, Single_RTS_Lock
'Access,
468 Result
:= pthread_cond_timedwait
469 (Self_ID
.Common
.LL
.CV
'Access, Self_ID
.Common
.LL
.L
'Access,
473 exit when Abs_Time
<= Monotonic_Clock
;
475 if Result
= 0 or else errno
= EINTR
then
487 -- This is for use in implementing delay statements, so we assume
488 -- the caller is abort-deferred but is holding no locks.
490 procedure Timed_Delay
493 Mode
: ST
.Delay_Modes
)
495 Check_Time
: constant Duration := Monotonic_Clock
;
497 Request
: aliased timespec
;
498 Result
: Interfaces
.C
.int
;
505 Write_Lock
(Self_ID
);
507 if Mode
= Relative
then
508 Abs_Time
:= Time
+ Check_Time
;
510 Abs_Time
:= Duration'Min (Check_Time
+ Max_Sensible_Delay
, Time
);
513 if Abs_Time
> Check_Time
then
514 Request
:= To_Timespec
(Abs_Time
);
515 Self_ID
.Common
.State
:= Delay_Sleep
;
518 if Self_ID
.Pending_Priority_Change
then
519 Self_ID
.Pending_Priority_Change
:= False;
520 Self_ID
.Common
.Base_Priority
:= Self_ID
.New_Base_Priority
;
521 Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
524 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
;
526 Result
:= pthread_cond_timedwait
(Self_ID
.Common
.LL
.CV
'Access,
527 Self_ID
.Common
.LL
.L
'Access, Request
'Access);
528 exit when Abs_Time
<= Monotonic_Clock
;
530 pragma Assert
(Result
= 0
531 or else Result
= ETIMEDOUT
532 or else Result
= EINTR
);
535 Self_ID
.Common
.State
:= Runnable
;
547 ---------------------
548 -- Monotonic_Clock --
549 ---------------------
551 function Monotonic_Clock
return Duration is
552 TS
: aliased timespec
;
553 Result
: Interfaces
.C
.int
;
555 Result
:= clock_gettime
(Real_Time_Clock_Id
, TS
'Unchecked_Access);
556 pragma Assert
(Result
= 0);
557 return To_Duration
(TS
);
564 function RT_Resolution
return Duration is
566 -- The clock_getres (Real_Time_Clock_Id) function appears to return
567 -- the interrupt resolution of the realtime clock and not the actual
568 -- resolution of reading the clock. Even though this last value is
569 -- only guaranteed to be 100 Hz, at least the Origin 200 appears to
570 -- have a microsecond resolution or better.
572 -- ??? We should figure out a method to return the right value on
582 procedure Wakeup
(T
: ST
.Task_Id
; Reason
: System
.Tasking
.Task_States
) is
583 pragma Unreferenced
(Reason
);
584 Result
: Interfaces
.C
.int
;
586 Result
:= pthread_cond_signal
(T
.Common
.LL
.CV
'Access);
587 pragma Assert
(Result
= 0);
594 procedure Yield
(Do_Yield
: Boolean := True) is
595 Result
: Interfaces
.C
.int
;
596 pragma Unreferenced
(Result
);
599 Result
:= sched_yield
;
607 procedure Set_Priority
609 Prio
: System
.Any_Priority
;
610 Loss_Of_Inheritance
: Boolean := False)
612 pragma Unreferenced
(Loss_Of_Inheritance
);
614 Result
: Interfaces
.C
.int
;
615 Param
: aliased struct_sched_param
;
616 Sched_Policy
: Interfaces
.C
.int
;
618 use type System
.Task_Info
.Task_Info_Type
;
620 function To_Int
is new Unchecked_Conversion
621 (System
.Task_Info
.Thread_Scheduling_Policy
, Interfaces
.C
.int
);
624 T
.Common
.Current_Priority
:= Prio
;
625 Param
.sched_priority
:= Interfaces
.C
.int
(Prio
);
627 if T
.Common
.Task_Info
/= null then
628 Sched_Policy
:= To_Int
(T
.Common
.Task_Info
.Policy
);
630 Sched_Policy
:= SCHED_FIFO
;
633 Result
:= pthread_setschedparam
(T
.Common
.LL
.Thread
, Sched_Policy
,
635 pragma Assert
(Result
= 0);
642 function Get_Priority
(T
: Task_Id
) return System
.Any_Priority
is
644 return T
.Common
.Current_Priority
;
651 procedure Enter_Task
(Self_ID
: Task_Id
) is
652 Result
: Interfaces
.C
.int
;
654 function To_Int
is new Unchecked_Conversion
655 (System
.Task_Info
.CPU_Number
, Interfaces
.C
.int
);
657 use System
.Task_Info
;
660 Self_ID
.Common
.LL
.Thread
:= pthread_self
;
661 Specific
.Set
(Self_ID
);
663 if Self_ID
.Common
.Task_Info
/= null
664 and then Self_ID
.Common
.Task_Info
.Scope
= PTHREAD_SCOPE_SYSTEM
665 and then Self_ID
.Common
.Task_Info
.Runon_CPU
/= ANY_CPU
667 Result
:= pthread_setrunon_np
668 (To_Int
(Self_ID
.Common
.Task_Info
.Runon_CPU
));
669 pragma Assert
(Result
= 0);
674 for J
in Known_Tasks
'Range loop
675 if Known_Tasks
(J
) = null then
676 Known_Tasks
(J
) := Self_ID
;
677 Self_ID
.Known_Tasks_Index
:= J
;
689 function New_ATCB
(Entry_Num
: Task_Entry_Index
) return Task_Id
is
691 return new Ada_Task_Control_Block
(Entry_Num
);
698 function Is_Valid_Task
return Boolean renames Specific
.Is_Valid_Task
;
700 -----------------------------
701 -- Register_Foreign_Thread --
702 -----------------------------
704 function Register_Foreign_Thread
return Task_Id
is
706 if Is_Valid_Task
then
709 return Register_Foreign_Thread
(pthread_self
);
711 end Register_Foreign_Thread
;
717 procedure Initialize_TCB
(Self_ID
: Task_Id
; Succeeded
: out Boolean) is
718 Result
: Interfaces
.C
.int
;
719 Cond_Attr
: aliased pthread_condattr_t
;
722 if not Single_Lock
then
723 Initialize_Lock
(Self_ID
.Common
.LL
.L
'Access, ATCB_Level
);
726 Result
:= pthread_condattr_init
(Cond_Attr
'Access);
727 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
730 Result
:= pthread_cond_init
(Self_ID
.Common
.LL
.CV
'Access,
732 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
738 if not Single_Lock
then
739 Result
:= pthread_mutex_destroy
(Self_ID
.Common
.LL
.L
'Access);
740 pragma Assert
(Result
= 0);
746 Result
:= pthread_condattr_destroy
(Cond_Attr
'Access);
747 pragma Assert
(Result
= 0);
754 procedure Create_Task
756 Wrapper
: System
.Address
;
757 Stack_Size
: System
.Parameters
.Size_Type
;
758 Priority
: System
.Any_Priority
;
759 Succeeded
: out Boolean)
761 use System
.Task_Info
;
763 Attributes
: aliased pthread_attr_t
;
764 Sched_Param
: aliased struct_sched_param
;
765 Result
: Interfaces
.C
.int
;
767 function Thread_Body_Access
is new
768 Unchecked_Conversion
(System
.Address
, Thread_Body
);
770 function To_Int
is new Unchecked_Conversion
771 (System
.Task_Info
.Thread_Scheduling_Scope
, Interfaces
.C
.int
);
772 function To_Int
is new Unchecked_Conversion
773 (System
.Task_Info
.Thread_Scheduling_Inheritance
, Interfaces
.C
.int
);
774 function To_Int
is new Unchecked_Conversion
775 (System
.Task_Info
.Thread_Scheduling_Policy
, Interfaces
.C
.int
);
778 Result
:= pthread_attr_init
(Attributes
'Access);
779 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
786 Result
:= pthread_attr_setdetachstate
787 (Attributes
'Access, PTHREAD_CREATE_DETACHED
);
788 pragma Assert
(Result
= 0);
790 Result
:= pthread_attr_setstacksize
791 (Attributes
'Access, Interfaces
.C
.size_t
(Stack_Size
));
792 pragma Assert
(Result
= 0);
794 if T
.Common
.Task_Info
/= null then
795 Result
:= pthread_attr_setscope
796 (Attributes
'Access, To_Int
(T
.Common
.Task_Info
.Scope
));
797 pragma Assert
(Result
= 0);
799 Result
:= pthread_attr_setinheritsched
800 (Attributes
'Access, To_Int
(T
.Common
.Task_Info
.Inheritance
));
801 pragma Assert
(Result
= 0);
803 Result
:= pthread_attr_setschedpolicy
804 (Attributes
'Access, To_Int
(T
.Common
.Task_Info
.Policy
));
805 pragma Assert
(Result
= 0);
807 Sched_Param
.sched_priority
:=
808 Interfaces
.C
.int
(T
.Common
.Task_Info
.Priority
);
810 Result
:= pthread_attr_setschedparam
811 (Attributes
'Access, Sched_Param
'Access);
812 pragma Assert
(Result
= 0);
815 -- Since the initial signal mask of a thread is inherited from the
816 -- creator, and the Environment task has all its signals masked, we
817 -- do not need to manipulate caller's signal mask at this point.
818 -- All tasks in RTS will have All_Tasks_Mask initially.
820 Result
:= pthread_create
821 (T
.Common
.LL
.Thread
'Access,
823 Thread_Body_Access
(Wrapper
),
827 and then T
.Common
.Task_Info
/= null
828 and then T
.Common
.Task_Info
.Scope
= PTHREAD_SCOPE_SYSTEM
830 -- The pthread_create call may have failed because we
831 -- asked for a system scope pthread and none were
832 -- available (probably because the program was not executed
833 -- by the superuser). Let's try for a process scope pthread
834 -- instead of raising Tasking_Error.
837 ("Request for PTHREAD_SCOPE_SYSTEM in Task_Info pragma for task");
838 System
.IO
.Put
("""");
839 System
.IO
.Put
(T
.Common
.Task_Image
(1 .. T
.Common
.Task_Image_Len
));
840 System
.IO
.Put_Line
(""" could not be honored. ");
841 System
.IO
.Put_Line
("Scope changed to PTHREAD_SCOPE_PROCESS");
843 T
.Common
.Task_Info
.Scope
:= PTHREAD_SCOPE_PROCESS
;
844 Result
:= pthread_attr_setscope
845 (Attributes
'Access, To_Int
(T
.Common
.Task_Info
.Scope
));
846 pragma Assert
(Result
= 0);
848 Result
:= pthread_create
849 (T
.Common
.LL
.Thread
'Access,
851 Thread_Body_Access
(Wrapper
),
855 pragma Assert
(Result
= 0 or else Result
= EAGAIN
);
857 Succeeded
:= Result
= 0;
859 -- The following needs significant commenting ???
861 if T
.Common
.Task_Info
/= null then
862 T
.Common
.Base_Priority
:= T
.Common
.Task_Info
.Priority
;
863 Set_Priority
(T
, T
.Common
.Task_Info
.Priority
);
865 Set_Priority
(T
, Priority
);
868 Result
:= pthread_attr_destroy
(Attributes
'Access);
869 pragma Assert
(Result
= 0);
876 procedure Finalize_TCB
(T
: Task_Id
) is
877 Result
: Interfaces
.C
.int
;
879 Is_Self
: constant Boolean := T
= Self
;
881 procedure Free
is new
882 Unchecked_Deallocation
(Ada_Task_Control_Block
, Task_Id
);
885 if not Single_Lock
then
886 Result
:= pthread_mutex_destroy
(T
.Common
.LL
.L
'Access);
887 pragma Assert
(Result
= 0);
890 Result
:= pthread_cond_destroy
(T
.Common
.LL
.CV
'Access);
891 pragma Assert
(Result
= 0);
893 if T
.Known_Tasks_Index
/= -1 then
894 Known_Tasks
(T
.Known_Tasks_Index
) := null;
908 procedure Exit_Task
is
917 procedure Abort_Task
(T
: Task_Id
) is
918 Result
: Interfaces
.C
.int
;
920 Result
:= pthread_kill
(T
.Common
.LL
.Thread
,
921 Signal
(System
.Interrupt_Management
.Abort_Task_Interrupt
));
922 pragma Assert
(Result
= 0);
929 procedure Initialize
(S
: in out Suspension_Object
) is
930 Mutex_Attr
: aliased pthread_mutexattr_t
;
931 Cond_Attr
: aliased pthread_condattr_t
;
932 Result
: Interfaces
.C
.int
;
934 -- Initialize internal state. It is always initialized to False (ARM
940 -- Initialize internal mutex
942 Result
:= pthread_mutexattr_init
(Mutex_Attr
'Access);
943 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
945 if Result
= ENOMEM
then
949 Result
:= pthread_mutex_init
(S
.L
'Access, Mutex_Attr
'Access);
950 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
952 if Result
= ENOMEM
then
953 Result
:= pthread_mutexattr_destroy
(Mutex_Attr
'Access);
954 pragma Assert
(Result
= 0);
959 Result
:= pthread_mutexattr_destroy
(Mutex_Attr
'Access);
960 pragma Assert
(Result
= 0);
962 -- Initialize internal condition variable
964 Result
:= pthread_condattr_init
(Cond_Attr
'Access);
965 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
968 Result
:= pthread_mutex_destroy
(S
.L
'Access);
969 pragma Assert
(Result
= 0);
971 if Result
= ENOMEM
then
976 Result
:= pthread_cond_init
(S
.CV
'Access, Cond_Attr
'Access);
977 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
980 Result
:= pthread_mutex_destroy
(S
.L
'Access);
981 pragma Assert
(Result
= 0);
983 if Result
= ENOMEM
then
984 Result
:= pthread_condattr_destroy
(Cond_Attr
'Access);
985 pragma Assert
(Result
= 0);
991 Result
:= pthread_condattr_destroy
(Cond_Attr
'Access);
992 pragma Assert
(Result
= 0);
999 procedure Finalize
(S
: in out Suspension_Object
) is
1000 Result
: Interfaces
.C
.int
;
1002 -- Destroy internal mutex
1004 Result
:= pthread_mutex_destroy
(S
.L
'Access);
1005 pragma Assert
(Result
= 0);
1007 -- Destroy internal condition variable
1009 Result
:= pthread_cond_destroy
(S
.CV
'Access);
1010 pragma Assert
(Result
= 0);
1017 function Current_State
(S
: Suspension_Object
) return Boolean is
1019 -- We do not want to use lock on this read operation. State is marked
1020 -- as Atomic so that we ensure that the value retrieved is correct.
1029 procedure Set_False
(S
: in out Suspension_Object
) is
1030 Result
: Interfaces
.C
.int
;
1032 SSL
.Abort_Defer
.all;
1034 Result
:= pthread_mutex_lock
(S
.L
'Access);
1035 pragma Assert
(Result
= 0);
1039 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1040 pragma Assert
(Result
= 0);
1042 SSL
.Abort_Undefer
.all;
1049 procedure Set_True
(S
: in out Suspension_Object
) is
1050 Result
: Interfaces
.C
.int
;
1052 SSL
.Abort_Defer
.all;
1054 Result
:= pthread_mutex_lock
(S
.L
'Access);
1055 pragma Assert
(Result
= 0);
1057 -- If there is already a task waiting on this suspension object then
1058 -- we resume it, leaving the state of the suspension object to False,
1059 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1060 -- the state to True.
1066 Result
:= pthread_cond_signal
(S
.CV
'Access);
1067 pragma Assert
(Result
= 0);
1072 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1073 pragma Assert
(Result
= 0);
1075 SSL
.Abort_Undefer
.all;
1078 ------------------------
1079 -- Suspend_Until_True --
1080 ------------------------
1082 procedure Suspend_Until_True
(S
: in out Suspension_Object
) is
1083 Result
: Interfaces
.C
.int
;
1085 SSL
.Abort_Defer
.all;
1087 Result
:= pthread_mutex_lock
(S
.L
'Access);
1088 pragma Assert
(Result
= 0);
1091 -- Program_Error must be raised upon calling Suspend_Until_True
1092 -- if another task is already waiting on that suspension object
1093 -- (ARM D.10 par. 10).
1095 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1096 pragma Assert
(Result
= 0);
1098 SSL
.Abort_Undefer
.all;
1100 raise Program_Error
;
1102 -- Suspend the task if the state is False. Otherwise, the task
1103 -- continues its execution, and the state of the suspension object
1104 -- is set to False (ARM D.10 par. 9).
1110 Result
:= pthread_cond_wait
(S
.CV
'Access, S
.L
'Access);
1113 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1114 pragma Assert
(Result
= 0);
1116 SSL
.Abort_Undefer
.all;
1118 end Suspend_Until_True
;
1126 function Check_Exit
(Self_ID
: ST
.Task_Id
) return Boolean is
1127 pragma Unreferenced
(Self_ID
);
1132 --------------------
1133 -- Check_No_Locks --
1134 --------------------
1136 function Check_No_Locks
(Self_ID
: ST
.Task_Id
) return Boolean is
1137 pragma Unreferenced
(Self_ID
);
1142 ----------------------
1143 -- Environment_Task --
1144 ----------------------
1146 function Environment_Task
return Task_Id
is
1148 return Environment_Task_Id
;
1149 end Environment_Task
;
1155 procedure Lock_RTS
is
1157 Write_Lock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1164 procedure Unlock_RTS
is
1166 Unlock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1173 function Suspend_Task
1175 Thread_Self
: Thread_Id
) return Boolean
1177 pragma Unreferenced
(T
);
1178 pragma Unreferenced
(Thread_Self
);
1187 function Resume_Task
1189 Thread_Self
: Thread_Id
) return Boolean
1191 pragma Unreferenced
(T
);
1192 pragma Unreferenced
(Thread_Self
);
1201 procedure Initialize
(Environment_Task
: Task_Id
) is
1202 act
: aliased struct_sigaction
;
1203 old_act
: aliased struct_sigaction
;
1204 Tmp_Set
: aliased sigset_t
;
1205 Result
: Interfaces
.C
.int
;
1208 (Int
: System
.Interrupt_Management
.Interrupt_ID
) return Character;
1209 pragma Import
(C
, State
, "__gnat_get_interrupt_state");
1210 -- Get interrupt state. Defined in a-init.c. The input argument is
1211 -- the interrupt number, and the result is one of the following:
1213 Default
: constant Character := 's';
1214 -- 'n' this interrupt not set by any Interrupt_State pragma
1215 -- 'u' Interrupt_State pragma set state to User
1216 -- 'r' Interrupt_State pragma set state to Runtime
1217 -- 's' Interrupt_State pragma set state to System (use "default"
1221 Environment_Task_Id
:= Environment_Task
;
1223 Interrupt_Management
.Initialize
;
1225 -- Initialize the lock used to synchronize chain of all ATCBs.
1227 Initialize_Lock
(Single_RTS_Lock
'Access, RTS_Lock_Level
);
1229 Specific
.Initialize
(Environment_Task
);
1231 Enter_Task
(Environment_Task
);
1233 -- Prepare the set of signals that should unblocked in all tasks
1235 Result
:= sigemptyset
(Unblocked_Signal_Mask
'Access);
1236 pragma Assert
(Result
= 0);
1238 for J
in Interrupt_Management
.Interrupt_ID
loop
1239 if System
.Interrupt_Management
.Keep_Unmasked
(J
) then
1240 Result
:= sigaddset
(Unblocked_Signal_Mask
'Access, Signal
(J
));
1241 pragma Assert
(Result
= 0);
1245 -- Install the abort-signal handler
1247 if State
(System
.Interrupt_Management
.Abort_Task_Interrupt
)
1251 act
.sa_handler
:= Abort_Handler
'Address;
1253 Result
:= sigemptyset
(Tmp_Set
'Access);
1254 pragma Assert
(Result
= 0);
1255 act
.sa_mask
:= Tmp_Set
;
1259 Signal
(System
.Interrupt_Management
.Abort_Task_Interrupt
),
1260 act
'Unchecked_Access,
1261 old_act
'Unchecked_Access);
1262 pragma Assert
(Result
= 0);
1266 end System
.Task_Primitives
.Operations
;