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-2005, 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
.Parameters
;
66 with System
.Program_Info
;
67 -- used for Default_Task_Stack
70 -- Pthread_Sched_Signal
73 with System
.OS_Interface
;
74 -- used for various type, constant, and operations
76 with Unchecked_Conversion
;
77 with Unchecked_Deallocation
;
79 package body System
.Task_Primitives
.Operations
is
82 use System
.Tasking
.Debug
;
84 use System
.OS_Interface
;
85 use System
.OS_Primitives
;
86 use System
.Parameters
;
92 -- The followings are logically constants, but need to be initialized
95 Single_RTS_Lock
: aliased RTS_Lock
;
96 -- This is a lock to allow only one thread of control in the RTS at
97 -- a time; it is used to execute in mutual exclusion from all other tasks.
98 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
100 ATCB_Key
: aliased pthread_key_t
;
101 -- Key used to find the Ada Task_Id associated with a thread
103 Environment_Task_Id
: Task_Id
;
104 -- A variable to hold Task_Id for the environment task
106 Locking_Policy
: Character;
107 pragma Import
(C
, Locking_Policy
, "__gl_locking_policy");
109 Real_Time_Clock_Id
: constant clockid_t
:= CLOCK_REALTIME
;
111 Unblocked_Signal_Mask
: aliased sigset_t
;
113 Foreign_Task_Elaborated
: aliased Boolean := True;
114 -- Used to identified fake tasks (i.e., non-Ada Threads)
122 procedure Initialize
(Environment_Task
: Task_Id
);
123 pragma Inline
(Initialize
);
124 -- Initialize various data needed by this package
126 function Is_Valid_Task
return Boolean;
127 pragma Inline
(Is_Valid_Task
);
128 -- Does executing thread have a TCB?
130 procedure Set
(Self_Id
: Task_Id
);
132 -- Set the self id for the current task
134 function Self
return Task_Id
;
135 pragma Inline
(Self
);
136 -- Return a pointer to the Ada Task Control Block of the calling task
140 package body Specific
is separate;
141 -- The body of this package is target specific
143 ---------------------------------
144 -- Support for foreign threads --
145 ---------------------------------
147 function Register_Foreign_Thread
(Thread
: Thread_Id
) return Task_Id
;
148 -- Allocate and Initialize a new ATCB for the current Thread
150 function Register_Foreign_Thread
151 (Thread
: Thread_Id
) return Task_Id
is separate;
153 -----------------------
154 -- Local Subprograms --
155 -----------------------
157 function To_Address
is new Unchecked_Conversion
(Task_Id
, System
.Address
);
159 procedure Abort_Handler
(Sig
: Signal
);
160 -- Signal handler used to implement asynchronous abort
166 procedure Abort_Handler
(Sig
: Signal
) is
167 pragma Unreferenced
(Sig
);
169 T
: constant Task_Id
:= Self
;
170 Result
: Interfaces
.C
.int
;
171 Old_Set
: aliased sigset_t
;
174 -- It is not safe to raise an exception when using ZCX and the GCC
175 -- exception handling mechanism.
177 if ZCX_By_Default
and then GCC_ZCX_Support
then
181 if T
.Deferral_Level
= 0
182 and then T
.Pending_ATC_Level
< T
.ATC_Nesting_Level
184 -- Make sure signals used for RTS internal purpose are unmasked
186 Result
:= pthread_sigmask
188 Unblocked_Signal_Mask
'Unchecked_Access,
189 Old_Set
'Unchecked_Access);
190 pragma Assert
(Result
= 0);
192 raise Standard
'Abort_Signal;
200 -- The underlying thread system sets a guard page at the
201 -- bottom of a thread stack, so nothing is needed.
203 procedure Stack_Guard
(T
: ST
.Task_Id
; On
: Boolean) is
204 pragma Unreferenced
(On
);
205 pragma Unreferenced
(T
);
214 function Get_Thread_Id
(T
: ST
.Task_Id
) return OSI
.Thread_Id
is
216 return T
.Common
.LL
.Thread
;
223 function Self
return Task_Id
renames Specific
.Self
;
225 ---------------------
226 -- Initialize_Lock --
227 ---------------------
229 -- Note: mutexes and cond_variables needed per-task basis are
230 -- initialized in Initialize_TCB and the Storage_Error is
231 -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
232 -- used in RTS is initialized before any status change of RTS.
233 -- Therefore rasing Storage_Error in the following routines
234 -- should be able to be handled safely.
236 procedure Initialize_Lock
237 (Prio
: System
.Any_Priority
;
240 Attributes
: aliased pthread_mutexattr_t
;
241 Result
: Interfaces
.C
.int
;
244 Result
:= pthread_mutexattr_init
(Attributes
'Access);
245 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
247 if Result
= ENOMEM
then
251 if Locking_Policy
= 'C' then
252 Result
:= pthread_mutexattr_setprotocol
253 (Attributes
'Access, PTHREAD_PRIO_PROTECT
);
254 pragma Assert
(Result
= 0);
256 Result
:= pthread_mutexattr_setprioceiling
257 (Attributes
'Access, Interfaces
.C
.int
(Prio
));
258 pragma Assert
(Result
= 0);
261 Result
:= pthread_mutex_init
(L
, Attributes
'Access);
262 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
264 if Result
= ENOMEM
then
265 Result
:= pthread_mutexattr_destroy
(Attributes
'Access);
269 Result
:= pthread_mutexattr_destroy
(Attributes
'Access);
270 pragma Assert
(Result
= 0);
273 procedure Initialize_Lock
(L
: access RTS_Lock
; Level
: Lock_Level
) is
274 pragma Unreferenced
(Level
);
276 Attributes
: aliased pthread_mutexattr_t
;
277 Result
: Interfaces
.C
.int
;
280 Result
:= pthread_mutexattr_init
(Attributes
'Access);
281 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
283 if Result
= ENOMEM
then
287 if Locking_Policy
= 'C' then
288 Result
:= pthread_mutexattr_setprotocol
289 (Attributes
'Access, PTHREAD_PRIO_PROTECT
);
290 pragma Assert
(Result
= 0);
292 Result
:= pthread_mutexattr_setprioceiling
293 (Attributes
'Access, Interfaces
.C
.int
(System
.Any_Priority
'Last));
294 pragma Assert
(Result
= 0);
297 Result
:= pthread_mutex_init
(L
, Attributes
'Access);
299 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
301 if Result
= ENOMEM
then
302 Result
:= pthread_mutexattr_destroy
(Attributes
'Access);
306 Result
:= pthread_mutexattr_destroy
(Attributes
'Access);
313 procedure Finalize_Lock
(L
: access Lock
) is
314 Result
: Interfaces
.C
.int
;
316 Result
:= pthread_mutex_destroy
(L
);
317 pragma Assert
(Result
= 0);
320 procedure Finalize_Lock
(L
: access RTS_Lock
) is
321 Result
: Interfaces
.C
.int
;
323 Result
:= pthread_mutex_destroy
(L
);
324 pragma Assert
(Result
= 0);
331 procedure Write_Lock
(L
: access Lock
; Ceiling_Violation
: out Boolean) is
332 Result
: Interfaces
.C
.int
;
334 Result
:= pthread_mutex_lock
(L
);
335 Ceiling_Violation
:= Result
= EINVAL
;
337 -- Assumes the cause of EINVAL is a priority ceiling violation
339 pragma Assert
(Result
= 0 or else Result
= EINVAL
);
343 (L
: access RTS_Lock
;
344 Global_Lock
: Boolean := False)
346 Result
: Interfaces
.C
.int
;
348 if not Single_Lock
or else Global_Lock
then
349 Result
:= pthread_mutex_lock
(L
);
350 pragma Assert
(Result
= 0);
354 procedure Write_Lock
(T
: Task_Id
) is
355 Result
: Interfaces
.C
.int
;
357 if not Single_Lock
then
358 Result
:= pthread_mutex_lock
(T
.Common
.LL
.L
'Access);
359 pragma Assert
(Result
= 0);
367 procedure Read_Lock
(L
: access Lock
; Ceiling_Violation
: out Boolean) is
369 Write_Lock
(L
, Ceiling_Violation
);
376 procedure Unlock
(L
: access Lock
) is
377 Result
: Interfaces
.C
.int
;
379 Result
:= pthread_mutex_unlock
(L
);
380 pragma Assert
(Result
= 0);
383 procedure Unlock
(L
: access RTS_Lock
; Global_Lock
: Boolean := False) is
384 Result
: Interfaces
.C
.int
;
387 if not Single_Lock
or else Global_Lock
then
388 Result
:= pthread_mutex_unlock
(L
);
389 pragma Assert
(Result
= 0);
393 procedure Unlock
(T
: Task_Id
) is
394 Result
: Interfaces
.C
.int
;
397 if not Single_Lock
then
398 Result
:= pthread_mutex_unlock
(T
.Common
.LL
.L
'Access);
399 pragma Assert
(Result
= 0);
408 (Self_ID
: ST
.Task_Id
;
409 Reason
: System
.Tasking
.Task_States
)
411 pragma Unreferenced
(Reason
);
413 Result
: Interfaces
.C
.int
;
417 Result
:= pthread_cond_wait
418 (Self_ID
.Common
.LL
.CV
'Access, Single_RTS_Lock
'Access);
420 Result
:= pthread_cond_wait
421 (Self_ID
.Common
.LL
.CV
'Access, Self_ID
.Common
.LL
.L
'Access);
424 -- EINTR is not considered a failure
426 pragma Assert
(Result
= 0 or else Result
= EINTR
);
433 procedure Timed_Sleep
436 Mode
: ST
.Delay_Modes
;
437 Reason
: Task_States
;
438 Timedout
: out Boolean;
439 Yielded
: out Boolean)
441 pragma Unreferenced
(Reason
);
443 Check_Time
: constant Duration := Monotonic_Clock
;
445 Request
: aliased timespec
;
446 Result
: Interfaces
.C
.int
;
452 if Mode
= Relative
then
453 Abs_Time
:= Duration'Min (Time
, Max_Sensible_Delay
) + Check_Time
;
455 Abs_Time
:= Duration'Min (Check_Time
+ Max_Sensible_Delay
, Time
);
458 if Abs_Time
> Check_Time
then
459 Request
:= To_Timespec
(Abs_Time
);
462 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
463 or else Self_ID
.Pending_Priority_Change
;
466 Result
:= pthread_cond_timedwait
467 (Self_ID
.Common
.LL
.CV
'Access, Single_RTS_Lock
'Access,
471 Result
:= pthread_cond_timedwait
472 (Self_ID
.Common
.LL
.CV
'Access, Self_ID
.Common
.LL
.L
'Access,
476 exit when Abs_Time
<= Monotonic_Clock
;
478 if Result
= 0 or else errno
= EINTR
then
490 -- This is for use in implementing delay statements, so we assume
491 -- the caller is abort-deferred but is holding no locks.
493 procedure Timed_Delay
496 Mode
: ST
.Delay_Modes
)
498 Check_Time
: constant Duration := Monotonic_Clock
;
500 Request
: aliased timespec
;
501 Result
: Interfaces
.C
.int
;
508 Write_Lock
(Self_ID
);
510 if Mode
= Relative
then
511 Abs_Time
:= Time
+ Check_Time
;
513 Abs_Time
:= Duration'Min (Check_Time
+ Max_Sensible_Delay
, Time
);
516 if Abs_Time
> Check_Time
then
517 Request
:= To_Timespec
(Abs_Time
);
518 Self_ID
.Common
.State
:= Delay_Sleep
;
521 if Self_ID
.Pending_Priority_Change
then
522 Self_ID
.Pending_Priority_Change
:= False;
523 Self_ID
.Common
.Base_Priority
:= Self_ID
.New_Base_Priority
;
524 Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
527 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
;
529 Result
:= pthread_cond_timedwait
(Self_ID
.Common
.LL
.CV
'Access,
530 Self_ID
.Common
.LL
.L
'Access, Request
'Access);
531 exit when Abs_Time
<= Monotonic_Clock
;
533 pragma Assert
(Result
= 0
534 or else Result
= ETIMEDOUT
535 or else Result
= EINTR
);
538 Self_ID
.Common
.State
:= Runnable
;
550 ---------------------
551 -- Monotonic_Clock --
552 ---------------------
554 function Monotonic_Clock
return Duration is
555 TS
: aliased timespec
;
556 Result
: Interfaces
.C
.int
;
558 Result
:= clock_gettime
(Real_Time_Clock_Id
, TS
'Unchecked_Access);
559 pragma Assert
(Result
= 0);
560 return To_Duration
(TS
);
567 function RT_Resolution
return Duration is
569 -- The clock_getres (Real_Time_Clock_Id) function appears to return
570 -- the interrupt resolution of the realtime clock and not the actual
571 -- resolution of reading the clock. Even though this last value is
572 -- only guaranteed to be 100 Hz, at least the Origin 200 appears to
573 -- have a microsecond resolution or better.
575 -- ??? We should figure out a method to return the right value on
585 procedure Wakeup
(T
: ST
.Task_Id
; Reason
: System
.Tasking
.Task_States
) is
586 pragma Unreferenced
(Reason
);
587 Result
: Interfaces
.C
.int
;
589 Result
:= pthread_cond_signal
(T
.Common
.LL
.CV
'Access);
590 pragma Assert
(Result
= 0);
597 procedure Yield
(Do_Yield
: Boolean := True) is
598 Result
: Interfaces
.C
.int
;
599 pragma Unreferenced
(Result
);
602 Result
:= sched_yield
;
610 procedure Set_Priority
612 Prio
: System
.Any_Priority
;
613 Loss_Of_Inheritance
: Boolean := False)
615 pragma Unreferenced
(Loss_Of_Inheritance
);
617 Result
: Interfaces
.C
.int
;
618 Param
: aliased struct_sched_param
;
619 Sched_Policy
: Interfaces
.C
.int
;
621 use type System
.Task_Info
.Task_Info_Type
;
623 function To_Int
is new Unchecked_Conversion
624 (System
.Task_Info
.Thread_Scheduling_Policy
, Interfaces
.C
.int
);
627 T
.Common
.Current_Priority
:= Prio
;
628 Param
.sched_priority
:= Interfaces
.C
.int
(Prio
);
630 if T
.Common
.Task_Info
/= null then
631 Sched_Policy
:= To_Int
(T
.Common
.Task_Info
.Policy
);
633 Sched_Policy
:= SCHED_FIFO
;
636 Result
:= pthread_setschedparam
(T
.Common
.LL
.Thread
, Sched_Policy
,
638 pragma Assert
(Result
= 0);
645 function Get_Priority
(T
: Task_Id
) return System
.Any_Priority
is
647 return T
.Common
.Current_Priority
;
654 procedure Enter_Task
(Self_ID
: Task_Id
) is
655 Result
: Interfaces
.C
.int
;
657 function To_Int
is new Unchecked_Conversion
658 (System
.Task_Info
.CPU_Number
, Interfaces
.C
.int
);
660 use System
.Task_Info
;
663 Self_ID
.Common
.LL
.Thread
:= pthread_self
;
664 Specific
.Set
(Self_ID
);
666 if Self_ID
.Common
.Task_Info
/= null
667 and then Self_ID
.Common
.Task_Info
.Scope
= PTHREAD_SCOPE_SYSTEM
668 and then Self_ID
.Common
.Task_Info
.Runon_CPU
/= ANY_CPU
670 Result
:= pthread_setrunon_np
671 (To_Int
(Self_ID
.Common
.Task_Info
.Runon_CPU
));
672 pragma Assert
(Result
= 0);
677 for J
in Known_Tasks
'Range loop
678 if Known_Tasks
(J
) = null then
679 Known_Tasks
(J
) := Self_ID
;
680 Self_ID
.Known_Tasks_Index
:= J
;
692 function New_ATCB
(Entry_Num
: Task_Entry_Index
) return Task_Id
is
694 return new Ada_Task_Control_Block
(Entry_Num
);
701 function Is_Valid_Task
return Boolean renames Specific
.Is_Valid_Task
;
703 -----------------------------
704 -- Register_Foreign_Thread --
705 -----------------------------
707 function Register_Foreign_Thread
return Task_Id
is
709 if Is_Valid_Task
then
712 return Register_Foreign_Thread
(pthread_self
);
714 end Register_Foreign_Thread
;
720 procedure Initialize_TCB
(Self_ID
: Task_Id
; Succeeded
: out Boolean) is
721 Result
: Interfaces
.C
.int
;
722 Cond_Attr
: aliased pthread_condattr_t
;
725 if not Single_Lock
then
726 Initialize_Lock
(Self_ID
.Common
.LL
.L
'Access, ATCB_Level
);
729 Result
:= pthread_condattr_init
(Cond_Attr
'Access);
730 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
733 Result
:= pthread_cond_init
(Self_ID
.Common
.LL
.CV
'Access,
735 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
741 if not Single_Lock
then
742 Result
:= pthread_mutex_destroy
(Self_ID
.Common
.LL
.L
'Access);
743 pragma Assert
(Result
= 0);
749 Result
:= pthread_condattr_destroy
(Cond_Attr
'Access);
750 pragma Assert
(Result
= 0);
757 procedure Create_Task
759 Wrapper
: System
.Address
;
760 Stack_Size
: System
.Parameters
.Size_Type
;
761 Priority
: System
.Any_Priority
;
762 Succeeded
: out Boolean)
764 use System
.Task_Info
;
766 Attributes
: aliased pthread_attr_t
;
767 Sched_Param
: aliased struct_sched_param
;
768 Adjusted_Stack_Size
: Interfaces
.C
.size_t
;
769 Result
: Interfaces
.C
.int
;
771 function Thread_Body_Access
is new
772 Unchecked_Conversion
(System
.Address
, Thread_Body
);
774 function To_Int
is new Unchecked_Conversion
775 (System
.Task_Info
.Thread_Scheduling_Scope
, Interfaces
.C
.int
);
776 function To_Int
is new Unchecked_Conversion
777 (System
.Task_Info
.Thread_Scheduling_Inheritance
, Interfaces
.C
.int
);
778 function To_Int
is new Unchecked_Conversion
779 (System
.Task_Info
.Thread_Scheduling_Policy
, Interfaces
.C
.int
);
782 if Stack_Size
= System
.Parameters
.Unspecified_Size
then
783 Adjusted_Stack_Size
:=
784 Interfaces
.C
.size_t
(System
.Program_Info
.Default_Task_Stack
);
786 elsif Stack_Size
< Size_Type
(Minimum_Stack_Size
) then
787 Adjusted_Stack_Size
:=
788 Interfaces
.C
.size_t
(Minimum_Stack_Size
);
791 Adjusted_Stack_Size
:= Interfaces
.C
.size_t
(Stack_Size
);
794 Result
:= pthread_attr_init
(Attributes
'Access);
795 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
802 Result
:= pthread_attr_setdetachstate
803 (Attributes
'Access, PTHREAD_CREATE_DETACHED
);
804 pragma Assert
(Result
= 0);
806 Result
:= pthread_attr_setstacksize
807 (Attributes
'Access, Adjusted_Stack_Size
);
808 pragma Assert
(Result
= 0);
810 if T
.Common
.Task_Info
/= null then
811 Result
:= pthread_attr_setscope
812 (Attributes
'Access, To_Int
(T
.Common
.Task_Info
.Scope
));
813 pragma Assert
(Result
= 0);
815 Result
:= pthread_attr_setinheritsched
816 (Attributes
'Access, To_Int
(T
.Common
.Task_Info
.Inheritance
));
817 pragma Assert
(Result
= 0);
819 Result
:= pthread_attr_setschedpolicy
820 (Attributes
'Access, To_Int
(T
.Common
.Task_Info
.Policy
));
821 pragma Assert
(Result
= 0);
823 Sched_Param
.sched_priority
:=
824 Interfaces
.C
.int
(T
.Common
.Task_Info
.Priority
);
826 Result
:= pthread_attr_setschedparam
827 (Attributes
'Access, Sched_Param
'Access);
828 pragma Assert
(Result
= 0);
831 -- Since the initial signal mask of a thread is inherited from the
832 -- creator, and the Environment task has all its signals masked, we
833 -- do not need to manipulate caller's signal mask at this point.
834 -- All tasks in RTS will have All_Tasks_Mask initially.
836 Result
:= pthread_create
837 (T
.Common
.LL
.Thread
'Access,
839 Thread_Body_Access
(Wrapper
),
843 and then T
.Common
.Task_Info
/= null
844 and then T
.Common
.Task_Info
.Scope
= PTHREAD_SCOPE_SYSTEM
846 -- The pthread_create call may have failed because we
847 -- asked for a system scope pthread and none were
848 -- available (probably because the program was not executed
849 -- by the superuser). Let's try for a process scope pthread
850 -- instead of raising Tasking_Error.
853 ("Request for PTHREAD_SCOPE_SYSTEM in Task_Info pragma for task");
854 System
.IO
.Put
("""");
855 System
.IO
.Put
(T
.Common
.Task_Image
(1 .. T
.Common
.Task_Image_Len
));
856 System
.IO
.Put_Line
(""" could not be honored. ");
857 System
.IO
.Put_Line
("Scope changed to PTHREAD_SCOPE_PROCESS");
859 T
.Common
.Task_Info
.Scope
:= PTHREAD_SCOPE_PROCESS
;
860 Result
:= pthread_attr_setscope
861 (Attributes
'Access, To_Int
(T
.Common
.Task_Info
.Scope
));
862 pragma Assert
(Result
= 0);
864 Result
:= pthread_create
865 (T
.Common
.LL
.Thread
'Access,
867 Thread_Body_Access
(Wrapper
),
871 pragma Assert
(Result
= 0 or else Result
= EAGAIN
);
873 Succeeded
:= Result
= 0;
875 -- The following needs significant commenting ???
877 if T
.Common
.Task_Info
/= null then
878 T
.Common
.Base_Priority
:= T
.Common
.Task_Info
.Priority
;
879 Set_Priority
(T
, T
.Common
.Task_Info
.Priority
);
881 Set_Priority
(T
, Priority
);
884 Result
:= pthread_attr_destroy
(Attributes
'Access);
885 pragma Assert
(Result
= 0);
892 procedure Finalize_TCB
(T
: Task_Id
) is
893 Result
: Interfaces
.C
.int
;
895 Is_Self
: constant Boolean := T
= Self
;
897 procedure Free
is new
898 Unchecked_Deallocation
(Ada_Task_Control_Block
, Task_Id
);
901 if not Single_Lock
then
902 Result
:= pthread_mutex_destroy
(T
.Common
.LL
.L
'Access);
903 pragma Assert
(Result
= 0);
906 Result
:= pthread_cond_destroy
(T
.Common
.LL
.CV
'Access);
907 pragma Assert
(Result
= 0);
909 if T
.Known_Tasks_Index
/= -1 then
910 Known_Tasks
(T
.Known_Tasks_Index
) := null;
924 procedure Exit_Task
is
933 procedure Abort_Task
(T
: Task_Id
) is
934 Result
: Interfaces
.C
.int
;
936 Result
:= pthread_kill
(T
.Common
.LL
.Thread
,
937 Signal
(System
.Interrupt_Management
.Abort_Task_Interrupt
));
938 pragma Assert
(Result
= 0);
945 procedure Initialize
(S
: in out Suspension_Object
) is
946 Mutex_Attr
: aliased pthread_mutexattr_t
;
947 Cond_Attr
: aliased pthread_condattr_t
;
948 Result
: Interfaces
.C
.int
;
950 -- Initialize internal state. It is always initialized to False (ARM
956 -- Initialize internal mutex
958 Result
:= pthread_mutexattr_init
(Mutex_Attr
'Access);
959 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
961 if Result
= ENOMEM
then
965 Result
:= pthread_mutex_init
(S
.L
'Access, Mutex_Attr
'Access);
966 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
968 if Result
= ENOMEM
then
969 Result
:= pthread_mutexattr_destroy
(Mutex_Attr
'Access);
970 pragma Assert
(Result
= 0);
975 Result
:= pthread_mutexattr_destroy
(Mutex_Attr
'Access);
976 pragma Assert
(Result
= 0);
978 -- Initialize internal condition variable
980 Result
:= pthread_condattr_init
(Cond_Attr
'Access);
981 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
984 Result
:= pthread_mutex_destroy
(S
.L
'Access);
985 pragma Assert
(Result
= 0);
987 if Result
= ENOMEM
then
992 Result
:= pthread_cond_init
(S
.CV
'Access, Cond_Attr
'Access);
993 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
996 Result
:= pthread_mutex_destroy
(S
.L
'Access);
997 pragma Assert
(Result
= 0);
999 if Result
= ENOMEM
then
1000 Result
:= pthread_condattr_destroy
(Cond_Attr
'Access);
1001 pragma Assert
(Result
= 0);
1003 raise Storage_Error
;
1007 Result
:= pthread_condattr_destroy
(Cond_Attr
'Access);
1008 pragma Assert
(Result
= 0);
1015 procedure Finalize
(S
: in out Suspension_Object
) is
1016 Result
: Interfaces
.C
.int
;
1018 -- Destroy internal mutex
1020 Result
:= pthread_mutex_destroy
(S
.L
'Access);
1021 pragma Assert
(Result
= 0);
1023 -- Destroy internal condition variable
1025 Result
:= pthread_cond_destroy
(S
.CV
'Access);
1026 pragma Assert
(Result
= 0);
1033 function Current_State
(S
: Suspension_Object
) return Boolean is
1035 -- We do not want to use lock on this read operation. State is marked
1036 -- as Atomic so that we ensure that the value retrieved is correct.
1045 procedure Set_False
(S
: in out Suspension_Object
) is
1046 Result
: Interfaces
.C
.int
;
1048 Result
:= pthread_mutex_lock
(S
.L
'Access);
1049 pragma Assert
(Result
= 0);
1053 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1054 pragma Assert
(Result
= 0);
1061 procedure Set_True
(S
: in out Suspension_Object
) is
1062 Result
: Interfaces
.C
.int
;
1064 Result
:= pthread_mutex_lock
(S
.L
'Access);
1065 pragma Assert
(Result
= 0);
1067 -- If there is already a task waiting on this suspension object then
1068 -- we resume it, leaving the state of the suspension object to False,
1069 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1070 -- the state to True.
1076 Result
:= pthread_cond_signal
(S
.CV
'Access);
1077 pragma Assert
(Result
= 0);
1082 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1083 pragma Assert
(Result
= 0);
1086 ------------------------
1087 -- Suspend_Until_True --
1088 ------------------------
1090 procedure Suspend_Until_True
(S
: in out Suspension_Object
) is
1091 Result
: Interfaces
.C
.int
;
1093 Result
:= pthread_mutex_lock
(S
.L
'Access);
1094 pragma Assert
(Result
= 0);
1097 -- Program_Error must be raised upon calling Suspend_Until_True
1098 -- if another task is already waiting on that suspension object
1099 -- (ARM D.10 par. 10).
1101 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1102 pragma Assert
(Result
= 0);
1104 raise Program_Error
;
1106 -- Suspend the task if the state is False. Otherwise, the task
1107 -- continues its execution, and the state of the suspension object
1108 -- is set to False (ARM D.10 par. 9).
1114 Result
:= pthread_cond_wait
(S
.CV
'Access, S
.L
'Access);
1118 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1119 pragma Assert
(Result
= 0);
1120 end Suspend_Until_True
;
1128 function Check_Exit
(Self_ID
: ST
.Task_Id
) return Boolean is
1129 pragma Unreferenced
(Self_ID
);
1134 --------------------
1135 -- Check_No_Locks --
1136 --------------------
1138 function Check_No_Locks
(Self_ID
: ST
.Task_Id
) return Boolean is
1139 pragma Unreferenced
(Self_ID
);
1144 ----------------------
1145 -- Environment_Task --
1146 ----------------------
1148 function Environment_Task
return Task_Id
is
1150 return Environment_Task_Id
;
1151 end Environment_Task
;
1157 procedure Lock_RTS
is
1159 Write_Lock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1166 procedure Unlock_RTS
is
1168 Unlock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1175 function Suspend_Task
1177 Thread_Self
: Thread_Id
) return Boolean
1179 pragma Unreferenced
(T
);
1180 pragma Unreferenced
(Thread_Self
);
1189 function Resume_Task
1191 Thread_Self
: Thread_Id
) return Boolean
1193 pragma Unreferenced
(T
);
1194 pragma Unreferenced
(Thread_Self
);
1203 procedure Initialize
(Environment_Task
: Task_Id
) is
1204 act
: aliased struct_sigaction
;
1205 old_act
: aliased struct_sigaction
;
1206 Tmp_Set
: aliased sigset_t
;
1207 Result
: Interfaces
.C
.int
;
1210 (Int
: System
.Interrupt_Management
.Interrupt_ID
) return Character;
1211 pragma Import
(C
, State
, "__gnat_get_interrupt_state");
1212 -- Get interrupt state. Defined in a-init.c. The input argument is
1213 -- the interrupt number, and the result is one of the following:
1215 Default
: constant Character := 's';
1216 -- 'n' this interrupt not set by any Interrupt_State pragma
1217 -- 'u' Interrupt_State pragma set state to User
1218 -- 'r' Interrupt_State pragma set state to Runtime
1219 -- 's' Interrupt_State pragma set state to System (use "default"
1223 Environment_Task_Id
:= Environment_Task
;
1225 Interrupt_Management
.Initialize
;
1227 -- Initialize the lock used to synchronize chain of all ATCBs.
1229 Initialize_Lock
(Single_RTS_Lock
'Access, RTS_Lock_Level
);
1231 Specific
.Initialize
(Environment_Task
);
1233 Enter_Task
(Environment_Task
);
1235 -- Prepare the set of signals that should unblocked in all tasks
1237 Result
:= sigemptyset
(Unblocked_Signal_Mask
'Access);
1238 pragma Assert
(Result
= 0);
1240 for J
in Interrupt_Management
.Interrupt_ID
loop
1241 if System
.Interrupt_Management
.Keep_Unmasked
(J
) then
1242 Result
:= sigaddset
(Unblocked_Signal_Mask
'Access, Signal
(J
));
1243 pragma Assert
(Result
= 0);
1247 -- Install the abort-signal handler
1249 if State
(System
.Interrupt_Management
.Abort_Task_Interrupt
)
1253 act
.sa_handler
:= Abort_Handler
'Address;
1255 Result
:= sigemptyset
(Tmp_Set
'Access);
1256 pragma Assert
(Result
= 0);
1257 act
.sa_mask
:= Tmp_Set
;
1261 Signal
(System
.Interrupt_Management
.Abort_Task_Interrupt
),
1262 act
'Unchecked_Access,
1263 old_act
'Unchecked_Access);
1264 pragma Assert
(Result
= 0);
1268 end System
.Task_Primitives
.Operations
;