1 ------------------------------------------------------------------------------
3 -- GNU ADA 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 --
10 -- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
12 -- GNARL is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNARL; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNARL was developed by the GNARL team at Florida State University. --
31 -- Extensive contributions were provided by Ada Core Technologies Inc. --
33 ------------------------------------------------------------------------------
35 -- This is a POSIX-like version of this package
37 -- This package contains all the GNULL primitives that interface directly
38 -- with the underlying OS.
40 -- Note: this file can only be used for POSIX compliant systems that
41 -- implement SCHED_FIFO and Ceiling Locking correctly.
43 -- For configurations where SCHED_FIFO and priority ceiling are not a
44 -- requirement, this file can also be used (e.g AiX threads)
47 -- Turn off polling, we do not want ATC polling to take place during
48 -- tasking operations. It causes infinite loops and other problems.
50 with System
.Tasking
.Debug
;
51 -- used for Known_Tasks
53 with System
.Task_Info
;
54 -- used for Task_Info_Type
60 with System
.Interrupt_Management
;
61 -- used for Keep_Unmasked
62 -- Abort_Task_Interrupt
65 with System
.Interrupt_Management
.Operations
;
66 -- used for Set_Interrupt_Mask
68 pragma Elaborate_All
(System
.Interrupt_Management
.Operations
);
70 with System
.Parameters
;
74 -- used for Ada_Task_Control_Block
77 with System
.Soft_Links
;
78 -- used for Defer/Undefer_Abort
80 -- Note that we do not use System.Tasking.Initialization directly since
81 -- this is a higher level package that we shouldn't depend on. For example
82 -- when using the restricted run time, it is replaced by
83 -- System.Tasking.Restricted.Initialization
85 with System
.OS_Primitives
;
86 -- used for Delay_Modes
88 with Unchecked_Conversion
;
89 with Unchecked_Deallocation
;
91 package body System
.Task_Primitives
.Operations
is
93 use System
.Tasking
.Debug
;
96 use System
.OS_Interface
;
97 use System
.Parameters
;
98 use System
.OS_Primitives
;
100 package SSL
renames System
.Soft_Links
;
106 -- The followings are logically constants, but need to be initialized
109 Single_RTS_Lock
: aliased RTS_Lock
;
110 -- This is a lock to allow only one thread of control in the RTS at
111 -- a time; it is used to execute in mutual exclusion from all other tasks.
112 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
114 Environment_Task_ID
: Task_ID
;
115 -- A variable to hold Task_ID for the environment task.
117 Locking_Policy
: Character;
118 pragma Import
(C
, Locking_Policy
, "__gl_locking_policy");
119 -- Value of the pragma Locking_Policy:
120 -- 'C' for Ceiling_Locking
121 -- 'I' for Inherit_Locking
124 Unblocked_Signal_Mask
: aliased sigset_t
;
125 -- The set of signals that should unblocked in all tasks
127 -- The followings are internal configuration constants needed.
129 Next_Serial_Number
: Task_Serial_Number
:= 100;
130 -- We start at 100, to reserve some special values for
131 -- using in error checking.
133 Time_Slice_Val
: Integer;
134 pragma Import
(C
, Time_Slice_Val
, "__gl_time_slice_val");
136 Dispatching_Policy
: Character;
137 pragma Import
(C
, Dispatching_Policy
, "__gl_task_dispatching_policy");
139 FIFO_Within_Priorities
: constant Boolean := Dispatching_Policy
= 'F';
140 -- Indicates whether FIFO_Within_Priorities is set.
142 -----------------------
143 -- Local Subprograms --
144 -----------------------
146 procedure Abort_Handler
(Sig
: Signal
);
148 function To_Task_ID
is new Unchecked_Conversion
(System
.Address
, Task_ID
);
150 function To_Address
is new Unchecked_Conversion
(Task_ID
, System
.Address
);
158 procedure Initialize
(Environment_Task
: Task_ID
);
159 pragma Inline
(Initialize
);
160 -- Initialize various data needed by this package.
162 procedure Set
(Self_Id
: Task_ID
);
164 -- Set the self id for the current task.
166 function Self
return Task_ID
;
167 pragma Inline
(Self
);
168 -- Return a pointer to the Ada Task Control Block of the calling task.
172 package body Specific
is separate;
173 -- The body of this package is target specific.
179 -- Target-dependent binding of inter-thread Abort signal to
180 -- the raising of the Abort_Signal exception.
182 -- The technical issues and alternatives here are essentially
183 -- the same as for raising exceptions in response to other
184 -- signals (e.g. Storage_Error). See code and comments in
185 -- the package body System.Interrupt_Management.
187 -- Some implementations may not allow an exception to be propagated
188 -- out of a handler, and others might leave the signal or
189 -- interrupt that invoked this handler masked after the exceptional
190 -- return to the application code.
192 -- GNAT exceptions are originally implemented using setjmp()/longjmp().
193 -- On most UNIX systems, this will allow transfer out of a signal handler,
194 -- which is usually the only mechanism available for implementing
195 -- asynchronous handlers of this kind. However, some
196 -- systems do not restore the signal mask on longjmp(), leaving the
197 -- abort signal masked.
199 -- Alternative solutions include:
201 -- 1. Change the PC saved in the system-dependent Context
202 -- parameter to point to code that raises the exception.
203 -- Normal return from this handler will then raise
204 -- the exception after the mask and other system state has
205 -- been restored (see example below).
207 -- 2. Use siglongjmp()/sigsetjmp() to implement exceptions.
209 -- 3. Unmask the signal in the Abortion_Signal exception handler
212 -- The following procedure would be needed if we can't lonjmp out of
213 -- a signal handler (See below)
215 -- procedure Raise_Abort_Signal is
217 -- raise Standard'Abort_Signal;
220 procedure Abort_Handler
224 Result
: Interfaces
.C
.int
;
225 Old_Set
: aliased sigset_t
;
228 -- Assuming it is safe to longjmp out of a signal handler, the
229 -- following code can be used:
231 if T
.Deferral_Level
= 0
232 and then T
.Pending_ATC_Level
< T
.ATC_Nesting_Level
and then
237 -- Make sure signals used for RTS internal purpose are unmasked
239 Result
:= pthread_sigmask
(SIG_UNBLOCK
,
240 Unblocked_Signal_Mask
'Unchecked_Access, Old_Set
'Unchecked_Access);
241 pragma Assert
(Result
= 0);
243 raise Standard
'Abort_Signal;
246 -- Otherwise, something like this is required:
247 -- if not Abort_Is_Deferred.all then
248 -- -- Overwrite the return PC address with the address of the
249 -- -- special raise routine, and "return" to that routine's
250 -- -- starting address.
251 -- Context.PC := Raise_Abort_Signal'Address;
260 procedure Stack_Guard
(T
: ST
.Task_ID
; On
: Boolean) is
261 Stack_Base
: constant Address
:= Get_Stack_Base
(T
.Common
.LL
.Thread
);
262 Guard_Page_Address
: Address
;
264 Res
: Interfaces
.C
.int
;
267 if Stack_Base_Available
then
268 -- Compute the guard page address
270 Guard_Page_Address
:=
271 Stack_Base
- (Stack_Base
mod Get_Page_Size
) + Get_Page_Size
;
274 Res
:= mprotect
(Guard_Page_Address
, Get_Page_Size
, PROT_ON
);
276 Res
:= mprotect
(Guard_Page_Address
, Get_Page_Size
, PROT_OFF
);
279 pragma Assert
(Res
= 0);
287 function Get_Thread_Id
(T
: ST
.Task_ID
) return OSI
.Thread_Id
is
289 return T
.Common
.LL
.Thread
;
296 function Self
return Task_ID
renames Specific
.Self
;
298 ---------------------
299 -- Initialize_Lock --
300 ---------------------
302 -- Note: mutexes and cond_variables needed per-task basis are
303 -- initialized in Initialize_TCB and the Storage_Error is
304 -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
305 -- used in RTS is initialized before any status change of RTS.
306 -- Therefore rasing Storage_Error in the following routines
307 -- should be able to be handled safely.
309 procedure Initialize_Lock
310 (Prio
: System
.Any_Priority
;
313 Attributes
: aliased pthread_mutexattr_t
;
314 Result
: Interfaces
.C
.int
;
317 Result
:= pthread_mutexattr_init
(Attributes
'Access);
318 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
320 if Result
= ENOMEM
then
324 if Locking_Policy
= 'C' then
325 Result
:= pthread_mutexattr_setprotocol
326 (Attributes
'Access, PTHREAD_PRIO_PROTECT
);
327 pragma Assert
(Result
= 0);
329 Result
:= pthread_mutexattr_setprioceiling
330 (Attributes
'Access, Interfaces
.C
.int
(Prio
));
331 pragma Assert
(Result
= 0);
333 elsif Locking_Policy
= 'I' then
334 Result
:= pthread_mutexattr_setprotocol
335 (Attributes
'Access, PTHREAD_PRIO_INHERIT
);
336 pragma Assert
(Result
= 0);
339 Result
:= pthread_mutex_init
(L
, Attributes
'Access);
340 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
342 if Result
= ENOMEM
then
346 Result
:= pthread_mutexattr_destroy
(Attributes
'Access);
347 pragma Assert
(Result
= 0);
350 procedure Initialize_Lock
(L
: access RTS_Lock
; Level
: Lock_Level
) is
351 Attributes
: aliased pthread_mutexattr_t
;
352 Result
: Interfaces
.C
.int
;
355 Result
:= pthread_mutexattr_init
(Attributes
'Access);
356 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
358 if Result
= ENOMEM
then
362 if Locking_Policy
= 'C' then
363 Result
:= pthread_mutexattr_setprotocol
364 (Attributes
'Access, PTHREAD_PRIO_PROTECT
);
365 pragma Assert
(Result
= 0);
367 Result
:= pthread_mutexattr_setprioceiling
368 (Attributes
'Access, Interfaces
.C
.int
(System
.Any_Priority
'Last));
369 pragma Assert
(Result
= 0);
371 elsif Locking_Policy
= 'I' then
372 Result
:= pthread_mutexattr_setprotocol
373 (Attributes
'Access, PTHREAD_PRIO_INHERIT
);
374 pragma Assert
(Result
= 0);
377 Result
:= pthread_mutex_init
(L
, Attributes
'Access);
378 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
380 if Result
= ENOMEM
then
381 Result
:= pthread_mutexattr_destroy
(Attributes
'Access);
385 Result
:= pthread_mutexattr_destroy
(Attributes
'Access);
386 pragma Assert
(Result
= 0);
393 procedure Finalize_Lock
(L
: access Lock
) is
394 Result
: Interfaces
.C
.int
;
396 Result
:= pthread_mutex_destroy
(L
);
397 pragma Assert
(Result
= 0);
400 procedure Finalize_Lock
(L
: access RTS_Lock
) is
401 Result
: Interfaces
.C
.int
;
403 Result
:= pthread_mutex_destroy
(L
);
404 pragma Assert
(Result
= 0);
411 procedure Write_Lock
(L
: access Lock
; Ceiling_Violation
: out Boolean) is
412 Result
: Interfaces
.C
.int
;
414 Result
:= pthread_mutex_lock
(L
);
416 -- Assume that the cause of EINVAL is a priority ceiling violation
418 Ceiling_Violation
:= (Result
= EINVAL
);
419 pragma Assert
(Result
= 0 or else Result
= EINVAL
);
423 (L
: access RTS_Lock
; Global_Lock
: Boolean := False)
425 Result
: Interfaces
.C
.int
;
427 if not Single_Lock
or else Global_Lock
then
428 Result
:= pthread_mutex_lock
(L
);
429 pragma Assert
(Result
= 0);
433 procedure Write_Lock
(T
: Task_ID
) is
434 Result
: Interfaces
.C
.int
;
436 if not Single_Lock
then
437 Result
:= pthread_mutex_lock
(T
.Common
.LL
.L
'Access);
438 pragma Assert
(Result
= 0);
446 procedure Read_Lock
(L
: access Lock
; Ceiling_Violation
: out Boolean) is
448 Write_Lock
(L
, Ceiling_Violation
);
455 procedure Unlock
(L
: access Lock
) is
456 Result
: Interfaces
.C
.int
;
458 Result
:= pthread_mutex_unlock
(L
);
459 pragma Assert
(Result
= 0);
462 procedure Unlock
(L
: access RTS_Lock
; Global_Lock
: Boolean := False) is
463 Result
: Interfaces
.C
.int
;
465 if not Single_Lock
or else Global_Lock
then
466 Result
:= pthread_mutex_unlock
(L
);
467 pragma Assert
(Result
= 0);
471 procedure Unlock
(T
: Task_ID
) is
472 Result
: Interfaces
.C
.int
;
474 if not Single_Lock
then
475 Result
:= pthread_mutex_unlock
(T
.Common
.LL
.L
'Access);
476 pragma Assert
(Result
= 0);
486 Reason
: System
.Tasking
.Task_States
)
488 Result
: Interfaces
.C
.int
;
491 Result
:= pthread_cond_wait
492 (Self_ID
.Common
.LL
.CV
'Access, Single_RTS_Lock
'Access);
494 Result
:= pthread_cond_wait
495 (Self_ID
.Common
.LL
.CV
'Access, Self_ID
.Common
.LL
.L
'Access);
498 -- EINTR is not considered a failure.
500 pragma Assert
(Result
= 0 or else Result
= EINTR
);
507 -- This is for use within the run-time system, so abort is
508 -- assumed to be already deferred, and the caller should be
509 -- holding its own ATCB lock.
511 procedure Timed_Sleep
514 Mode
: ST
.Delay_Modes
;
515 Reason
: Task_States
;
516 Timedout
: out Boolean;
517 Yielded
: out Boolean)
519 Check_Time
: constant Duration := Monotonic_Clock
;
522 Request
: aliased timespec
;
523 Result
: Interfaces
.C
.int
;
529 if Mode
= Relative
then
530 Abs_Time
:= Duration'Min (Time
, Max_Sensible_Delay
) + Check_Time
;
532 if Relative_Timed_Wait
then
533 Rel_Time
:= Duration'Min (Max_Sensible_Delay
, Time
);
537 Abs_Time
:= Duration'Min (Check_Time
+ Max_Sensible_Delay
, Time
);
539 if Relative_Timed_Wait
then
540 Rel_Time
:= Duration'Min (Max_Sensible_Delay
, Time
- Check_Time
);
544 if Abs_Time
> Check_Time
then
545 if Relative_Timed_Wait
then
546 Request
:= To_Timespec
(Rel_Time
);
548 Request
:= To_Timespec
(Abs_Time
);
552 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
553 or else Self_ID
.Pending_Priority_Change
;
556 Result
:= pthread_cond_timedwait
557 (Self_ID
.Common
.LL
.CV
'Access, Single_RTS_Lock
'Access,
561 Result
:= pthread_cond_timedwait
562 (Self_ID
.Common
.LL
.CV
'Access, Self_ID
.Common
.LL
.L
'Access,
566 exit when Abs_Time
<= Monotonic_Clock
;
568 if Result
= 0 or Result
= EINTR
then
570 -- Somebody may have called Wakeup for us
576 pragma Assert
(Result
= ETIMEDOUT
);
585 -- This is for use in implementing delay statements, so
586 -- we assume the caller is abort-deferred but is holding
589 procedure Timed_Delay
592 Mode
: ST
.Delay_Modes
)
594 Check_Time
: constant Duration := Monotonic_Clock
;
597 Request
: aliased timespec
;
598 Result
: Interfaces
.C
.int
;
601 -- Only the little window between deferring abort and
602 -- locking Self_ID is the reason we need to
603 -- check for pending abort and priority change below! :(
611 Write_Lock
(Self_ID
);
613 if Mode
= Relative
then
614 Abs_Time
:= Duration'Min (Time
, Max_Sensible_Delay
) + Check_Time
;
616 if Relative_Timed_Wait
then
617 Rel_Time
:= Duration'Min (Max_Sensible_Delay
, Time
);
621 Abs_Time
:= Duration'Min (Check_Time
+ Max_Sensible_Delay
, Time
);
623 if Relative_Timed_Wait
then
624 Rel_Time
:= Duration'Min (Max_Sensible_Delay
, Time
- Check_Time
);
628 if Abs_Time
> Check_Time
then
629 if Relative_Timed_Wait
then
630 Request
:= To_Timespec
(Rel_Time
);
632 Request
:= To_Timespec
(Abs_Time
);
635 Self_ID
.Common
.State
:= Delay_Sleep
;
638 if Self_ID
.Pending_Priority_Change
then
639 Self_ID
.Pending_Priority_Change
:= False;
640 Self_ID
.Common
.Base_Priority
:= Self_ID
.New_Base_Priority
;
641 Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
644 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
;
647 Result
:= pthread_cond_timedwait
(Self_ID
.Common
.LL
.CV
'Access,
648 Single_RTS_Lock
'Access, Request
'Access);
650 Result
:= pthread_cond_timedwait
(Self_ID
.Common
.LL
.CV
'Access,
651 Self_ID
.Common
.LL
.L
'Access, Request
'Access);
654 exit when Abs_Time
<= Monotonic_Clock
;
656 pragma Assert
(Result
= 0
657 or else Result
= ETIMEDOUT
658 or else Result
= EINTR
);
661 Self_ID
.Common
.State
:= Runnable
;
670 Result
:= sched_yield
;
671 SSL
.Abort_Undefer
.all;
674 ---------------------
675 -- Monotonic_Clock --
676 ---------------------
678 function Monotonic_Clock
return Duration is
679 TS
: aliased timespec
;
680 Result
: Interfaces
.C
.int
;
683 Result
:= clock_gettime
684 (clock_id
=> CLOCK_REALTIME
, tp
=> TS
'Unchecked_Access);
685 pragma Assert
(Result
= 0);
686 return To_Duration
(TS
);
693 function RT_Resolution
return Duration is
702 procedure Wakeup
(T
: Task_ID
; Reason
: System
.Tasking
.Task_States
) is
703 Result
: Interfaces
.C
.int
;
705 Result
:= pthread_cond_signal
(T
.Common
.LL
.CV
'Access);
706 pragma Assert
(Result
= 0);
713 procedure Yield
(Do_Yield
: Boolean := True) is
714 Result
: Interfaces
.C
.int
;
717 Result
:= sched_yield
;
725 procedure Set_Priority
727 Prio
: System
.Any_Priority
;
728 Loss_Of_Inheritance
: Boolean := False)
730 Result
: Interfaces
.C
.int
;
731 Param
: aliased struct_sched_param
;
734 T
.Common
.Current_Priority
:= Prio
;
735 Param
.sched_priority
:= Interfaces
.C
.int
(Prio
);
737 if Time_Slice_Supported
and then Time_Slice_Val
> 0 then
738 Result
:= pthread_setschedparam
739 (T
.Common
.LL
.Thread
, SCHED_RR
, Param
'Access);
741 elsif FIFO_Within_Priorities
or else Time_Slice_Val
= 0 then
742 Result
:= pthread_setschedparam
743 (T
.Common
.LL
.Thread
, SCHED_FIFO
, Param
'Access);
746 Result
:= pthread_setschedparam
747 (T
.Common
.LL
.Thread
, SCHED_OTHER
, Param
'Access);
750 pragma Assert
(Result
= 0);
757 function Get_Priority
(T
: Task_ID
) return System
.Any_Priority
is
759 return T
.Common
.Current_Priority
;
766 procedure Enter_Task
(Self_ID
: Task_ID
) is
768 Self_ID
.Common
.LL
.Thread
:= pthread_self
;
769 Self_ID
.Common
.LL
.LWP
:= lwp_self
;
771 Specific
.Set
(Self_ID
);
775 for J
in Known_Tasks
'Range loop
776 if Known_Tasks
(J
) = null then
777 Known_Tasks
(J
) := Self_ID
;
778 Self_ID
.Known_Tasks_Index
:= J
;
790 function New_ATCB
(Entry_Num
: Task_Entry_Index
) return Task_ID
is
792 return new Ada_Task_Control_Block
(Entry_Num
);
795 ----------------------
797 ----------------------
799 procedure Initialize_TCB
(Self_ID
: Task_ID
; Succeeded
: out Boolean) is
800 Mutex_Attr
: aliased pthread_mutexattr_t
;
801 Result
: Interfaces
.C
.int
;
802 Cond_Attr
: aliased pthread_condattr_t
;
805 -- Give the task a unique serial number.
807 Self_ID
.Serial_Number
:= Next_Serial_Number
;
808 Next_Serial_Number
:= Next_Serial_Number
+ 1;
809 pragma Assert
(Next_Serial_Number
/= 0);
811 if not Single_Lock
then
812 Result
:= pthread_mutexattr_init
(Mutex_Attr
'Access);
813 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
816 Result
:= pthread_mutexattr_setprotocol
817 (Mutex_Attr
'Access, PTHREAD_PRIO_PROTECT
);
818 pragma Assert
(Result
= 0);
820 Result
:= pthread_mutexattr_setprioceiling
821 (Mutex_Attr
'Access, Interfaces
.C
.int
(System
.Any_Priority
'Last));
822 pragma Assert
(Result
= 0);
824 Result
:= pthread_mutex_init
(Self_ID
.Common
.LL
.L
'Access,
826 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
834 Result
:= pthread_mutexattr_destroy
(Mutex_Attr
'Access);
835 pragma Assert
(Result
= 0);
838 Result
:= pthread_condattr_init
(Cond_Attr
'Access);
839 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
842 Result
:= pthread_cond_init
(Self_ID
.Common
.LL
.CV
'Access,
844 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
850 if not Single_Lock
then
851 Result
:= pthread_mutex_destroy
(Self_ID
.Common
.LL
.L
'Access);
852 pragma Assert
(Result
= 0);
858 Result
:= pthread_condattr_destroy
(Cond_Attr
'Access);
859 pragma Assert
(Result
= 0);
866 procedure Create_Task
868 Wrapper
: System
.Address
;
869 Stack_Size
: System
.Parameters
.Size_Type
;
870 Priority
: System
.Any_Priority
;
871 Succeeded
: out Boolean)
873 Attributes
: aliased pthread_attr_t
;
874 Adjusted_Stack_Size
: Interfaces
.C
.size_t
;
875 Result
: Interfaces
.C
.int
;
877 function Thread_Body_Access
is new
878 Unchecked_Conversion
(System
.Address
, Thread_Body
);
880 use System
.Task_Info
;
883 if Stack_Size
= Unspecified_Size
then
884 Adjusted_Stack_Size
:= Interfaces
.C
.size_t
(Default_Stack_Size
);
886 elsif Stack_Size
< Minimum_Stack_Size
then
887 Adjusted_Stack_Size
:= Interfaces
.C
.size_t
(Minimum_Stack_Size
);
890 Adjusted_Stack_Size
:= Interfaces
.C
.size_t
(Stack_Size
);
893 if Stack_Base_Available
then
894 -- If Stack Checking is supported then allocate 2 additional pages:
896 -- In the worst case, stack is allocated at something like
897 -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages
898 -- to be sure the effective stack size is greater than what
901 Adjusted_Stack_Size
:= Adjusted_Stack_Size
+ 2 * Get_Page_Size
;
904 Result
:= pthread_attr_init
(Attributes
'Access);
905 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
912 Result
:= pthread_attr_setdetachstate
913 (Attributes
'Access, PTHREAD_CREATE_DETACHED
);
914 pragma Assert
(Result
= 0);
916 Result
:= pthread_attr_setstacksize
917 (Attributes
'Access, Adjusted_Stack_Size
);
918 pragma Assert
(Result
= 0);
920 if T
.Common
.Task_Info
/= Default_Scope
then
922 -- We are assuming that Scope_Type has the same values than the
923 -- corresponding C macros
925 Result
:= pthread_attr_setscope
926 (Attributes
'Access, Task_Info_Type
'Pos (T
.Common
.Task_Info
));
927 pragma Assert
(Result
= 0);
930 -- Since the initial signal mask of a thread is inherited from the
931 -- creator, and the Environment task has all its signals masked, we
932 -- do not need to manipulate caller's signal mask at this point.
933 -- All tasks in RTS will have All_Tasks_Mask initially.
935 Result
:= pthread_create
936 (T
.Common
.LL
.Thread
'Access,
938 Thread_Body_Access
(Wrapper
),
940 pragma Assert
(Result
= 0 or else Result
= EAGAIN
);
942 Succeeded
:= Result
= 0;
944 Result
:= pthread_attr_destroy
(Attributes
'Access);
945 pragma Assert
(Result
= 0);
947 Set_Priority
(T
, Priority
);
954 procedure Finalize_TCB
(T
: Task_ID
) is
955 Result
: Interfaces
.C
.int
;
958 procedure Free
is new
959 Unchecked_Deallocation
(Ada_Task_Control_Block
, Task_ID
);
962 if not Single_Lock
then
963 Result
:= pthread_mutex_destroy
(T
.Common
.LL
.L
'Access);
964 pragma Assert
(Result
= 0);
967 Result
:= pthread_cond_destroy
(T
.Common
.LL
.CV
'Access);
968 pragma Assert
(Result
= 0);
970 if T
.Known_Tasks_Index
/= -1 then
971 Known_Tasks
(T
.Known_Tasks_Index
) := null;
981 procedure Exit_Task
is
983 pthread_exit
(System
.Null_Address
);
990 procedure Abort_Task
(T
: Task_ID
) is
991 Result
: Interfaces
.C
.int
;
994 Result
:= pthread_kill
(T
.Common
.LL
.Thread
,
995 Signal
(System
.Interrupt_Management
.Abort_Task_Interrupt
));
996 pragma Assert
(Result
= 0);
1003 -- Dummy versions. The only currently working versions is for solaris
1006 function Check_Exit
(Self_ID
: ST
.Task_ID
) return Boolean is
1011 --------------------
1012 -- Check_No_Locks --
1013 --------------------
1015 function Check_No_Locks
(Self_ID
: ST
.Task_ID
) return Boolean is
1020 ----------------------
1021 -- Environment_Task --
1022 ----------------------
1024 function Environment_Task
return Task_ID
is
1026 return Environment_Task_ID
;
1027 end Environment_Task
;
1033 procedure Lock_RTS
is
1035 Write_Lock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1042 procedure Unlock_RTS
is
1044 Unlock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1051 function Suspend_Task
1053 Thread_Self
: Thread_Id
) return Boolean is
1062 function Resume_Task
1064 Thread_Self
: Thread_Id
) return Boolean is
1073 procedure Initialize
(Environment_Task
: Task_ID
) is
1074 act
: aliased struct_sigaction
;
1075 old_act
: aliased struct_sigaction
;
1076 Tmp_Set
: aliased sigset_t
;
1077 Result
: Interfaces
.C
.int
;
1080 Environment_Task_ID
:= Environment_Task
;
1082 -- Initialize the lock used to synchronize chain of all ATCBs.
1084 Initialize_Lock
(Single_RTS_Lock
'Access, RTS_Lock_Level
);
1086 Specific
.Initialize
(Environment_Task
);
1088 Enter_Task
(Environment_Task
);
1090 -- Install the abort-signal handler
1093 act
.sa_handler
:= Abort_Handler
'Address;
1095 Result
:= sigemptyset
(Tmp_Set
'Access);
1096 pragma Assert
(Result
= 0);
1097 act
.sa_mask
:= Tmp_Set
;
1101 Signal
(System
.Interrupt_Management
.Abort_Task_Interrupt
),
1102 act
'Unchecked_Access,
1103 old_act
'Unchecked_Access);
1105 pragma Assert
(Result
= 0);
1110 Result
: Interfaces
.C
.int
;
1112 -- Mask Environment task for all signals. The original mask of the
1113 -- Environment task will be recovered by Interrupt_Server task
1114 -- during the elaboration of s-interr.adb.
1116 System
.Interrupt_Management
.Operations
.Set_Interrupt_Mask
1117 (System
.Interrupt_Management
.Operations
.All_Tasks_Mask
'Access);
1119 -- Prepare the set of signals that should unblocked in all tasks
1121 Result
:= sigemptyset
(Unblocked_Signal_Mask
'Access);
1122 pragma Assert
(Result
= 0);
1124 for J
in Interrupt_Management
.Interrupt_ID
loop
1125 if System
.Interrupt_Management
.Keep_Unmasked
(J
) then
1126 Result
:= sigaddset
(Unblocked_Signal_Mask
'Access, Signal
(J
));
1127 pragma Assert
(Result
= 0);
1131 end System
.Task_Primitives
.Operations
;