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-2011, 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 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
30 ------------------------------------------------------------------------------
32 -- This is a IRIX (pthread library) version of this package
34 -- This package contains all the GNULL primitives that interface directly with
38 -- Turn off polling, we do not want ATC polling to take place during tasking
39 -- operations. It causes infinite loops and other problems.
41 with Ada
.Unchecked_Conversion
;
45 with System
.Task_Info
;
46 with System
.Tasking
.Debug
;
47 with System
.Interrupt_Management
;
48 with System
.OS_Primitives
;
51 with System
.Soft_Links
;
52 -- We use System.Soft_Links instead of System.Tasking.Initialization
53 -- because the later is a higher level package that we shouldn't depend on.
54 -- For example when using the restricted run time, it is replaced by
55 -- System.Tasking.Restricted.Stages.
57 package body System
.Task_Primitives
.Operations
is
59 package SSL
renames System
.Soft_Links
;
62 use System
.Tasking
.Debug
;
64 use System
.OS_Interface
;
65 use System
.OS_Primitives
;
66 use System
.Parameters
;
72 -- The followings are logically constants, but need to be initialized
75 Single_RTS_Lock
: aliased RTS_Lock
;
76 -- This is a lock to allow only one thread of control in the RTS at
77 -- a time; it is used to execute in mutual exclusion from all other tasks.
78 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
80 Environment_Task_Id
: Task_Id
;
81 -- A variable to hold Task_Id for the environment task
83 Locking_Policy
: Character;
84 pragma Import
(C
, Locking_Policy
, "__gl_locking_policy");
86 Time_Slice_Val
: Integer;
87 pragma Import
(C
, Time_Slice_Val
, "__gl_time_slice_val");
89 Dispatching_Policy
: Character;
90 pragma Import
(C
, Dispatching_Policy
, "__gl_task_dispatching_policy");
92 Real_Time_Clock_Id
: constant clockid_t
:= CLOCK_REALTIME
;
94 Unblocked_Signal_Mask
: aliased sigset_t
;
96 Foreign_Task_Elaborated
: aliased Boolean := True;
97 -- Used to identified fake tasks (i.e., non-Ada Threads)
99 Abort_Handler_Installed
: Boolean := False;
100 -- True if a handler for the abort signal is installed
108 procedure Initialize
(Environment_Task
: Task_Id
);
109 pragma Inline
(Initialize
);
110 -- Initialize various data needed by this package
112 function Is_Valid_Task
return Boolean;
113 pragma Inline
(Is_Valid_Task
);
114 -- Does executing thread have a TCB?
116 procedure Set
(Self_Id
: Task_Id
);
118 -- Set the self id for the current task
120 function Self
return Task_Id
;
121 pragma Inline
(Self
);
122 -- Return a pointer to the Ada Task Control Block of the calling task
126 package body Specific
is separate;
127 -- The body of this package is target specific
129 ----------------------------------
130 -- ATCB allocation/deallocation --
131 ----------------------------------
133 package body ATCB_Allocation
is separate;
134 -- The body of this package is shared across several targets
136 ---------------------------------
137 -- Support for foreign threads --
138 ---------------------------------
140 function Register_Foreign_Thread
(Thread
: Thread_Id
) return Task_Id
;
141 -- Allocate and Initialize a new ATCB for the current Thread
143 function Register_Foreign_Thread
144 (Thread
: Thread_Id
) return Task_Id
is separate;
146 -----------------------
147 -- Local Subprograms --
148 -----------------------
150 function To_Address
is
151 new Ada
.Unchecked_Conversion
(Task_Id
, System
.Address
);
153 procedure Abort_Handler
(Sig
: Signal
);
154 -- Signal handler used to implement asynchronous abort
160 procedure Abort_Handler
(Sig
: Signal
) is
161 pragma Unreferenced
(Sig
);
163 T
: constant Task_Id
:= Self
;
164 Result
: Interfaces
.C
.int
;
165 Old_Set
: aliased sigset_t
;
168 -- It's not safe to raise an exception when using GCC ZCX mechanism.
169 -- Note that we still need to install a signal handler, since in some
170 -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we
171 -- need to send the Abort signal to a task.
173 if ZCX_By_Default
then
177 if T
.Deferral_Level
= 0
178 and then T
.Pending_ATC_Level
< T
.ATC_Nesting_Level
180 -- Make sure signals used for RTS internal purpose are unmasked
182 Result
:= pthread_sigmask
184 Unblocked_Signal_Mask
'Access,
186 pragma Assert
(Result
= 0);
188 raise Standard
'Abort_Signal;
196 -- The underlying thread system sets a guard page at the
197 -- bottom of a thread stack, so nothing is needed.
199 procedure Stack_Guard
(T
: ST
.Task_Id
; On
: Boolean) is
200 pragma Unreferenced
(On
);
201 pragma Unreferenced
(T
);
210 function Get_Thread_Id
(T
: ST
.Task_Id
) return OSI
.Thread_Id
is
212 return T
.Common
.LL
.Thread
;
219 function Self
return Task_Id
renames Specific
.Self
;
221 ---------------------
222 -- Initialize_Lock --
223 ---------------------
225 -- Note: mutexes and cond_variables needed per-task basis are initialized
226 -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
227 -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
228 -- status change of RTS. Therefore raising Storage_Error in the following
229 -- routines should be able to be handled safely.
231 procedure Initialize_Lock
232 (Prio
: System
.Any_Priority
;
233 L
: not null access Lock
)
235 Attributes
: aliased pthread_mutexattr_t
;
236 Result
: Interfaces
.C
.int
;
239 Result
:= pthread_mutexattr_init
(Attributes
'Access);
240 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
242 if Result
= ENOMEM
then
246 if Locking_Policy
= 'C' then
248 pthread_mutexattr_setprotocol
249 (Attributes
'Access, PTHREAD_PRIO_PROTECT
);
250 pragma Assert
(Result
= 0);
253 pthread_mutexattr_setprioceiling
254 (Attributes
'Access, Interfaces
.C
.int
(Prio
));
255 pragma Assert
(Result
= 0);
258 Result
:= pthread_mutex_init
(L
.WO
'Access, 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
271 (L
: not null access RTS_Lock
;
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);
307 pragma Assert
(Result
= 0);
314 procedure Finalize_Lock
(L
: not null access Lock
) is
315 Result
: Interfaces
.C
.int
;
317 Result
:= pthread_mutex_destroy
(L
.WO
'Access);
318 pragma Assert
(Result
= 0);
321 procedure Finalize_Lock
(L
: not null access RTS_Lock
) is
322 Result
: Interfaces
.C
.int
;
324 Result
:= pthread_mutex_destroy
(L
);
325 pragma Assert
(Result
= 0);
333 (L
: not null access Lock
; Ceiling_Violation
: out Boolean)
335 Result
: Interfaces
.C
.int
;
338 Result
:= pthread_mutex_lock
(L
.WO
'Access);
339 Ceiling_Violation
:= Result
= EINVAL
;
341 -- Assumes the cause of EINVAL is a priority ceiling violation
343 pragma Assert
(Result
= 0 or else Result
= EINVAL
);
347 (L
: not null access RTS_Lock
;
348 Global_Lock
: Boolean := False)
350 Result
: Interfaces
.C
.int
;
352 if not Single_Lock
or else Global_Lock
then
353 Result
:= pthread_mutex_lock
(L
);
354 pragma Assert
(Result
= 0);
358 procedure Write_Lock
(T
: Task_Id
) is
359 Result
: Interfaces
.C
.int
;
361 if not Single_Lock
then
362 Result
:= pthread_mutex_lock
(T
.Common
.LL
.L
'Access);
363 pragma Assert
(Result
= 0);
372 (L
: not null access Lock
; Ceiling_Violation
: out Boolean) is
374 Write_Lock
(L
, Ceiling_Violation
);
381 procedure Unlock
(L
: not null access Lock
) is
382 Result
: Interfaces
.C
.int
;
384 Result
:= pthread_mutex_unlock
(L
.WO
'Access);
385 pragma Assert
(Result
= 0);
389 (L
: not null access RTS_Lock
;
390 Global_Lock
: Boolean := False)
392 Result
: Interfaces
.C
.int
;
394 if not Single_Lock
or else Global_Lock
then
395 Result
:= pthread_mutex_unlock
(L
);
396 pragma Assert
(Result
= 0);
400 procedure Unlock
(T
: Task_Id
) is
401 Result
: Interfaces
.C
.int
;
403 if not Single_Lock
then
404 Result
:= pthread_mutex_unlock
(T
.Common
.LL
.L
'Access);
405 pragma Assert
(Result
= 0);
413 -- Dynamic priority ceilings are not supported by the underlying system
415 procedure Set_Ceiling
416 (L
: not null access Lock
;
417 Prio
: System
.Any_Priority
)
419 pragma Unreferenced
(L
, Prio
);
429 (Self_ID
: ST
.Task_Id
;
430 Reason
: System
.Tasking
.Task_States
)
432 pragma Unreferenced
(Reason
);
433 Result
: Interfaces
.C
.int
;
438 (cond
=> Self_ID
.Common
.LL
.CV
'Access,
439 mutex
=> (if Single_Lock
440 then Single_RTS_Lock
'Access
441 else Self_ID
.Common
.LL
.L
'Access));
443 -- EINTR is not considered a failure
445 pragma Assert
(Result
= 0 or else Result
= EINTR
);
452 procedure Timed_Sleep
455 Mode
: ST
.Delay_Modes
;
456 Reason
: Task_States
;
457 Timedout
: out Boolean;
458 Yielded
: out Boolean)
460 pragma Unreferenced
(Reason
);
462 Base_Time
: constant Duration := Monotonic_Clock
;
463 Check_Time
: Duration := Base_Time
;
465 Request
: aliased timespec
;
466 Result
: Interfaces
.C
.int
;
474 then Duration'Min (Time
, Max_Sensible_Delay
) + Check_Time
475 else Duration'Min (Check_Time
+ Max_Sensible_Delay
, Time
));
477 if Abs_Time
> Check_Time
then
478 Request
:= To_Timespec
(Abs_Time
);
481 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
;
484 pthread_cond_timedwait
485 (cond
=> Self_ID
.Common
.LL
.CV
'Access,
486 mutex
=> (if Single_Lock
487 then Single_RTS_Lock
'Access
488 else Self_ID
.Common
.LL
.L
'Access),
489 abstime
=> Request
'Access);
491 Check_Time
:= Monotonic_Clock
;
492 exit when Abs_Time
<= Check_Time
or else Check_Time
< Base_Time
;
494 if Result
= 0 or else errno
= EINTR
then
506 -- This is for use in implementing delay statements, so we assume
507 -- the caller is abort-deferred but is holding no locks.
509 procedure Timed_Delay
512 Mode
: ST
.Delay_Modes
)
514 Base_Time
: constant Duration := Monotonic_Clock
;
515 Check_Time
: Duration := Base_Time
;
517 Request
: aliased timespec
;
518 Result
: Interfaces
.C
.int
;
525 Write_Lock
(Self_ID
);
529 then Time
+ Check_Time
530 else Duration'Min (Check_Time
+ Max_Sensible_Delay
, Time
));
532 if Abs_Time
> Check_Time
then
533 Request
:= To_Timespec
(Abs_Time
);
534 Self_ID
.Common
.State
:= Delay_Sleep
;
537 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
;
540 pthread_cond_timedwait
541 (cond
=> Self_ID
.Common
.LL
.CV
'Access,
542 mutex
=> (if Single_Lock
543 then Single_RTS_Lock
'Access
544 else Self_ID
.Common
.LL
.L
'Access),
545 abstime
=> Request
'Access);
547 Check_Time
:= Monotonic_Clock
;
548 exit when Abs_Time
<= Check_Time
or else Check_Time
< Base_Time
;
550 pragma Assert
(Result
= 0
551 or else Result
= ETIMEDOUT
552 or else Result
= EINTR
);
555 Self_ID
.Common
.State
:= Runnable
;
567 ---------------------
568 -- Monotonic_Clock --
569 ---------------------
571 function Monotonic_Clock
return Duration is
572 TS
: aliased timespec
;
573 Result
: Interfaces
.C
.int
;
575 Result
:= clock_gettime
(Real_Time_Clock_Id
, TS
'Unchecked_Access);
576 pragma Assert
(Result
= 0);
577 return To_Duration
(TS
);
584 function RT_Resolution
return Duration is
586 -- The clock_getres (Real_Time_Clock_Id) function appears to return
587 -- the interrupt resolution of the realtime clock and not the actual
588 -- resolution of reading the clock. Even though this last value is
589 -- only guaranteed to be 100 Hz, at least the Origin 200 appears to
590 -- have a microsecond resolution or better.
592 -- ??? We should figure out a method to return the right value on
602 procedure Wakeup
(T
: ST
.Task_Id
; Reason
: System
.Tasking
.Task_States
) is
603 pragma Unreferenced
(Reason
);
604 Result
: Interfaces
.C
.int
;
606 Result
:= pthread_cond_signal
(T
.Common
.LL
.CV
'Access);
607 pragma Assert
(Result
= 0);
614 procedure Yield
(Do_Yield
: Boolean := True) is
615 Result
: Interfaces
.C
.int
;
616 pragma Unreferenced
(Result
);
619 Result
:= sched_yield
;
627 procedure Set_Priority
629 Prio
: System
.Any_Priority
;
630 Loss_Of_Inheritance
: Boolean := False)
632 pragma Unreferenced
(Loss_Of_Inheritance
);
634 Result
: Interfaces
.C
.int
;
635 Param
: aliased struct_sched_param
;
636 Sched_Policy
: Interfaces
.C
.int
;
638 use type System
.Task_Info
.Task_Info_Type
;
640 function To_Int
is new Ada
.Unchecked_Conversion
641 (System
.Task_Info
.Thread_Scheduling_Policy
, Interfaces
.C
.int
);
643 function Get_Policy
(Prio
: System
.Any_Priority
) return Character;
644 pragma Import
(C
, Get_Policy
, "__gnat_get_specific_dispatching");
645 -- Get priority specific dispatching policy
647 Priority_Specific_Policy
: constant Character := Get_Policy
(Prio
);
648 -- Upper case first character of the policy name corresponding to the
649 -- task as set by a Priority_Specific_Dispatching pragma.
652 T
.Common
.Current_Priority
:= Prio
;
653 Param
.sched_priority
:= Interfaces
.C
.int
(Prio
);
655 if T
.Common
.Task_Info
/= null then
656 Sched_Policy
:= To_Int
(T
.Common
.Task_Info
.Policy
);
658 elsif Dispatching_Policy
= 'R'
659 or else Priority_Specific_Policy
= 'R'
660 or else Time_Slice_Val
> 0
662 Sched_Policy
:= SCHED_RR
;
665 Sched_Policy
:= SCHED_FIFO
;
668 Result
:= pthread_setschedparam
(T
.Common
.LL
.Thread
, Sched_Policy
,
670 pragma Assert
(Result
= 0);
677 function Get_Priority
(T
: Task_Id
) return System
.Any_Priority
is
679 return T
.Common
.Current_Priority
;
686 procedure Enter_Task
(Self_ID
: Task_Id
) is
687 Result
: Interfaces
.C
.int
;
689 function To_Int
is new Ada
.Unchecked_Conversion
690 (System
.Task_Info
.CPU_Number
, Interfaces
.C
.int
);
692 use System
.Task_Info
;
695 Self_ID
.Common
.LL
.Thread
:= pthread_self
;
696 Specific
.Set
(Self_ID
);
698 if Self_ID
.Common
.Task_Info
/= null
699 and then Self_ID
.Common
.Task_Info
.Scope
= PTHREAD_SCOPE_SYSTEM
700 and then Self_ID
.Common
.Task_Info
.Runon_CPU
/= ANY_CPU
702 Result
:= pthread_setrunon_np
703 (To_Int
(Self_ID
.Common
.Task_Info
.Runon_CPU
));
704 pragma Assert
(Result
= 0);
712 function Is_Valid_Task
return Boolean renames Specific
.Is_Valid_Task
;
714 -----------------------------
715 -- Register_Foreign_Thread --
716 -----------------------------
718 function Register_Foreign_Thread
return Task_Id
is
720 if Is_Valid_Task
then
723 return Register_Foreign_Thread
(pthread_self
);
725 end Register_Foreign_Thread
;
731 procedure Initialize_TCB
(Self_ID
: Task_Id
; Succeeded
: out Boolean) is
732 Result
: Interfaces
.C
.int
;
733 Cond_Attr
: aliased pthread_condattr_t
;
736 if not Single_Lock
then
737 Initialize_Lock
(Self_ID
.Common
.LL
.L
'Access, ATCB_Level
);
740 Result
:= pthread_condattr_init
(Cond_Attr
'Access);
741 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
745 pthread_cond_init
(Self_ID
.Common
.LL
.CV
'Access, Cond_Attr
'Access);
746 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
752 if not Single_Lock
then
753 Result
:= pthread_mutex_destroy
(Self_ID
.Common
.LL
.L
'Access);
754 pragma Assert
(Result
= 0);
760 Result
:= pthread_condattr_destroy
(Cond_Attr
'Access);
761 pragma Assert
(Result
= 0);
768 procedure Create_Task
770 Wrapper
: System
.Address
;
771 Stack_Size
: System
.Parameters
.Size_Type
;
772 Priority
: System
.Any_Priority
;
773 Succeeded
: out Boolean)
775 use System
.Task_Info
;
777 Attributes
: aliased pthread_attr_t
;
778 Sched_Param
: aliased struct_sched_param
;
779 Result
: Interfaces
.C
.int
;
781 function Thread_Body_Access
is new
782 Ada
.Unchecked_Conversion
(System
.Address
, Thread_Body
);
783 function To_Int
is new Ada
.Unchecked_Conversion
784 (System
.Task_Info
.Thread_Scheduling_Scope
, Interfaces
.C
.int
);
785 function To_Int
is new Ada
.Unchecked_Conversion
786 (System
.Task_Info
.Thread_Scheduling_Inheritance
, Interfaces
.C
.int
);
787 function To_Int
is new Ada
.Unchecked_Conversion
788 (System
.Task_Info
.Thread_Scheduling_Policy
, Interfaces
.C
.int
);
791 Result
:= pthread_attr_init
(Attributes
'Access);
792 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
800 pthread_attr_setdetachstate
801 (Attributes
'Access, PTHREAD_CREATE_DETACHED
);
802 pragma Assert
(Result
= 0);
805 pthread_attr_setstacksize
806 (Attributes
'Access, Interfaces
.C
.size_t
(Stack_Size
));
807 pragma Assert
(Result
= 0);
809 if T
.Common
.Task_Info
/= null then
811 pthread_attr_setscope
812 (Attributes
'Access, To_Int
(T
.Common
.Task_Info
.Scope
));
813 pragma Assert
(Result
= 0);
816 pthread_attr_setinheritsched
817 (Attributes
'Access, To_Int
(T
.Common
.Task_Info
.Inheritance
));
818 pragma Assert
(Result
= 0);
821 pthread_attr_setschedpolicy
822 (Attributes
'Access, To_Int
(T
.Common
.Task_Info
.Policy
));
823 pragma Assert
(Result
= 0);
825 Sched_Param
.sched_priority
:=
826 Interfaces
.C
.int
(T
.Common
.Task_Info
.Priority
);
829 pthread_attr_setschedparam
830 (Attributes
'Access, Sched_Param
'Access);
831 pragma Assert
(Result
= 0);
834 -- Since the initial signal mask of a thread is inherited from the
835 -- creator, and the Environment task has all its signals masked, we
836 -- do not need to manipulate caller's signal mask at this point.
837 -- All tasks in RTS will have All_Tasks_Mask initially.
841 (T
.Common
.LL
.Thread
'Access,
843 Thread_Body_Access
(Wrapper
),
847 and then T
.Common
.Task_Info
/= null
848 and then T
.Common
.Task_Info
.Scope
= PTHREAD_SCOPE_SYSTEM
850 -- The pthread_create call may have failed because we asked for a
851 -- system scope pthread and none were available (probably because
852 -- the program was not executed by the superuser). Let's try for
853 -- a process scope pthread instead of raising Tasking_Error.
856 ("Request for PTHREAD_SCOPE_SYSTEM in Task_Info pragma for task");
857 System
.IO
.Put
("""");
858 System
.IO
.Put
(T
.Common
.Task_Image
(1 .. T
.Common
.Task_Image_Len
));
859 System
.IO
.Put_Line
(""" could not be honored. ");
860 System
.IO
.Put_Line
("Scope changed to PTHREAD_SCOPE_PROCESS");
862 T
.Common
.Task_Info
.Scope
:= PTHREAD_SCOPE_PROCESS
;
864 pthread_attr_setscope
865 (Attributes
'Access, To_Int
(T
.Common
.Task_Info
.Scope
));
866 pragma Assert
(Result
= 0);
870 (T
.Common
.LL
.Thread
'Access,
872 Thread_Body_Access
(Wrapper
),
876 pragma Assert
(Result
= 0 or else Result
= EAGAIN
);
878 Succeeded
:= Result
= 0;
882 -- The following needs significant commenting ???
884 if T
.Common
.Task_Info
/= null then
885 T
.Common
.Base_Priority
:= T
.Common
.Task_Info
.Priority
;
886 Set_Priority
(T
, T
.Common
.Task_Info
.Priority
);
888 Set_Priority
(T
, Priority
);
892 Result
:= pthread_attr_destroy
(Attributes
'Access);
893 pragma Assert
(Result
= 0);
900 procedure Finalize_TCB
(T
: Task_Id
) is
901 Result
: Interfaces
.C
.int
;
904 if not Single_Lock
then
905 Result
:= pthread_mutex_destroy
(T
.Common
.LL
.L
'Access);
906 pragma Assert
(Result
= 0);
909 Result
:= pthread_cond_destroy
(T
.Common
.LL
.CV
'Access);
910 pragma Assert
(Result
= 0);
912 if T
.Known_Tasks_Index
/= -1 then
913 Known_Tasks
(T
.Known_Tasks_Index
) := null;
916 ATCB_Allocation
.Free_ATCB
(T
);
923 procedure Exit_Task
is
932 procedure Abort_Task
(T
: Task_Id
) is
933 Result
: Interfaces
.C
.int
;
935 if Abort_Handler_Installed
then
939 Signal
(System
.Interrupt_Management
.Abort_Task_Interrupt
));
940 pragma Assert
(Result
= 0);
948 procedure Initialize
(S
: in out Suspension_Object
) is
949 Mutex_Attr
: aliased pthread_mutexattr_t
;
950 Cond_Attr
: aliased pthread_condattr_t
;
951 Result
: Interfaces
.C
.int
;
954 -- Initialize internal state (always to False (RM D.10(6))
959 -- Initialize internal mutex
961 Result
:= pthread_mutexattr_init
(Mutex_Attr
'Access);
962 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
964 if Result
= ENOMEM
then
968 Result
:= pthread_mutex_init
(S
.L
'Access, Mutex_Attr
'Access);
969 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
971 if Result
= ENOMEM
then
972 Result
:= pthread_mutexattr_destroy
(Mutex_Attr
'Access);
973 pragma Assert
(Result
= 0);
978 Result
:= pthread_mutexattr_destroy
(Mutex_Attr
'Access);
979 pragma Assert
(Result
= 0);
981 -- Initialize internal condition variable
983 Result
:= pthread_condattr_init
(Cond_Attr
'Access);
984 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
987 Result
:= pthread_mutex_destroy
(S
.L
'Access);
988 pragma Assert
(Result
= 0);
990 if Result
= ENOMEM
then
995 Result
:= pthread_cond_init
(S
.CV
'Access, Cond_Attr
'Access);
996 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
999 Result
:= pthread_mutex_destroy
(S
.L
'Access);
1000 pragma Assert
(Result
= 0);
1002 if Result
= ENOMEM
then
1003 Result
:= pthread_condattr_destroy
(Cond_Attr
'Access);
1004 pragma Assert
(Result
= 0);
1005 raise Storage_Error
;
1009 Result
:= pthread_condattr_destroy
(Cond_Attr
'Access);
1010 pragma Assert
(Result
= 0);
1017 procedure Finalize
(S
: in out Suspension_Object
) is
1018 Result
: Interfaces
.C
.int
;
1021 -- Destroy internal mutex
1023 Result
:= pthread_mutex_destroy
(S
.L
'Access);
1024 pragma Assert
(Result
= 0);
1026 -- Destroy internal condition variable
1028 Result
:= pthread_cond_destroy
(S
.CV
'Access);
1029 pragma Assert
(Result
= 0);
1036 function Current_State
(S
: Suspension_Object
) return Boolean is
1038 -- We do not want to use lock on this read operation. State is marked
1039 -- as Atomic so that we ensure that the value retrieved is correct.
1048 procedure Set_False
(S
: in out Suspension_Object
) is
1049 Result
: Interfaces
.C
.int
;
1052 SSL
.Abort_Defer
.all;
1054 Result
:= pthread_mutex_lock
(S
.L
'Access);
1055 pragma Assert
(Result
= 0);
1059 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1060 pragma Assert
(Result
= 0);
1062 SSL
.Abort_Undefer
.all;
1069 procedure Set_True
(S
: in out Suspension_Object
) is
1070 Result
: Interfaces
.C
.int
;
1073 SSL
.Abort_Defer
.all;
1075 Result
:= pthread_mutex_lock
(S
.L
'Access);
1076 pragma Assert
(Result
= 0);
1078 -- If there is already a task waiting on this suspension object then
1079 -- we resume it, leaving the state of the suspension object to False,
1080 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1081 -- the state to True.
1087 Result
:= pthread_cond_signal
(S
.CV
'Access);
1088 pragma Assert
(Result
= 0);
1094 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1095 pragma Assert
(Result
= 0);
1097 SSL
.Abort_Undefer
.all;
1100 ------------------------
1101 -- Suspend_Until_True --
1102 ------------------------
1104 procedure Suspend_Until_True
(S
: in out Suspension_Object
) is
1105 Result
: Interfaces
.C
.int
;
1108 SSL
.Abort_Defer
.all;
1110 Result
:= pthread_mutex_lock
(S
.L
'Access);
1111 pragma Assert
(Result
= 0);
1115 -- Program_Error must be raised upon calling Suspend_Until_True
1116 -- if another task is already waiting on that suspension object
1119 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1120 pragma Assert
(Result
= 0);
1122 SSL
.Abort_Undefer
.all;
1124 raise Program_Error
;
1126 -- Suspend the task if the state is False. Otherwise, the task
1127 -- continues its execution, and the state of the suspension object
1128 -- is set to False (ARM D.10 par. 9).
1136 -- Loop in case pthread_cond_wait returns earlier than expected
1137 -- (e.g. in case of EINTR caused by a signal).
1139 Result
:= pthread_cond_wait
(S
.CV
'Access, S
.L
'Access);
1140 pragma Assert
(Result
= 0 or else Result
= EINTR
);
1142 exit when not S
.Waiting
;
1146 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1147 pragma Assert
(Result
= 0);
1149 SSL
.Abort_Undefer
.all;
1151 end Suspend_Until_True
;
1159 function Check_Exit
(Self_ID
: ST
.Task_Id
) return Boolean is
1160 pragma Unreferenced
(Self_ID
);
1165 --------------------
1166 -- Check_No_Locks --
1167 --------------------
1169 function Check_No_Locks
(Self_ID
: ST
.Task_Id
) return Boolean is
1170 pragma Unreferenced
(Self_ID
);
1175 ----------------------
1176 -- Environment_Task --
1177 ----------------------
1179 function Environment_Task
return Task_Id
is
1181 return Environment_Task_Id
;
1182 end Environment_Task
;
1188 procedure Lock_RTS
is
1190 Write_Lock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1197 procedure Unlock_RTS
is
1199 Unlock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1206 function Suspend_Task
1208 Thread_Self
: Thread_Id
) return Boolean
1210 pragma Unreferenced
(T
);
1211 pragma Unreferenced
(Thread_Self
);
1220 function Resume_Task
1222 Thread_Self
: Thread_Id
) return Boolean
1224 pragma Unreferenced
(T
);
1225 pragma Unreferenced
(Thread_Self
);
1230 --------------------
1231 -- Stop_All_Tasks --
1232 --------------------
1234 procedure Stop_All_Tasks
is
1243 function Stop_Task
(T
: ST
.Task_Id
) return Boolean is
1244 pragma Unreferenced
(T
);
1253 function Continue_Task
(T
: ST
.Task_Id
) return Boolean is
1254 pragma Unreferenced
(T
);
1263 procedure Initialize
(Environment_Task
: Task_Id
) is
1264 act
: aliased struct_sigaction
;
1265 old_act
: aliased struct_sigaction
;
1266 Tmp_Set
: aliased sigset_t
;
1267 Result
: Interfaces
.C
.int
;
1270 (Int
: System
.Interrupt_Management
.Interrupt_ID
) return Character;
1271 pragma Import
(C
, State
, "__gnat_get_interrupt_state");
1272 -- Get interrupt state. Defined in a-init.c. The input argument is
1273 -- the interrupt number, and the result is one of the following:
1275 Default
: constant Character := 's';
1276 -- 'n' this interrupt not set by any Interrupt_State pragma
1277 -- 'u' Interrupt_State pragma set state to User
1278 -- 'r' Interrupt_State pragma set state to Runtime
1279 -- 's' Interrupt_State pragma set state to System (use "default"
1283 Environment_Task_Id
:= Environment_Task
;
1285 Interrupt_Management
.Initialize
;
1287 -- Initialize the lock used to synchronize chain of all ATCBs
1289 Initialize_Lock
(Single_RTS_Lock
'Access, RTS_Lock_Level
);
1291 Specific
.Initialize
(Environment_Task
);
1293 -- Make environment task known here because it doesn't go through
1294 -- Activate_Tasks, which does it for all other tasks.
1296 Known_Tasks
(Known_Tasks
'First) := Environment_Task
;
1297 Environment_Task
.Known_Tasks_Index
:= Known_Tasks
'First;
1299 Enter_Task
(Environment_Task
);
1301 -- Prepare the set of signals that should unblocked in all tasks
1303 Result
:= sigemptyset
(Unblocked_Signal_Mask
'Access);
1304 pragma Assert
(Result
= 0);
1306 for J
in Interrupt_Management
.Interrupt_ID
loop
1307 if System
.Interrupt_Management
.Keep_Unmasked
(J
) then
1308 Result
:= sigaddset
(Unblocked_Signal_Mask
'Access, Signal
(J
));
1309 pragma Assert
(Result
= 0);
1314 (System
.Interrupt_Management
.Abort_Task_Interrupt
) /= Default
1317 act
.sa_handler
:= Abort_Handler
'Address;
1319 Result
:= sigemptyset
(Tmp_Set
'Access);
1320 pragma Assert
(Result
= 0);
1321 act
.sa_mask
:= Tmp_Set
;
1325 (Signal
(System
.Interrupt_Management
.Abort_Task_Interrupt
),
1326 act
'Unchecked_Access,
1327 old_act
'Unchecked_Access);
1328 pragma Assert
(Result
= 0);
1329 Abort_Handler_Installed
:= True;
1333 -----------------------
1334 -- Set_Task_Affinity --
1335 -----------------------
1337 procedure Set_Task_Affinity
(T
: ST
.Task_Id
) is
1338 pragma Unreferenced
(T
);
1341 -- Setting task affinity is not supported by the underlying system
1344 end Set_Task_Affinity
;
1346 end System
.Task_Primitives
.Operations
;