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-2010, 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 the VxWorks 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
;
42 with Ada
.Unchecked_Deallocation
;
46 with System
.Tasking
.Debug
;
47 with System
.Interrupt_Management
;
49 with System
.Soft_Links
;
50 -- We use System.Soft_Links instead of System.Tasking.Initialization
51 -- because the later is a higher level package that we shouldn't depend
52 -- on. For example when using the restricted run time, it is replaced by
53 -- System.Tasking.Restricted.Stages.
55 with System
.Task_Info
;
56 with System
.VxWorks
.Ext
;
58 package body System
.Task_Primitives
.Operations
is
60 package SSL
renames System
.Soft_Links
;
62 use System
.Tasking
.Debug
;
64 use System
.OS_Interface
;
65 use System
.Parameters
;
66 use type System
.VxWorks
.Ext
.t_id
;
67 use type Interfaces
.C
.int
;
69 subtype int
is System
.OS_Interface
.int
;
71 Relative
: constant := 0;
77 -- The followings are logically constants, but need to be initialized at
80 Single_RTS_Lock
: aliased RTS_Lock
;
81 -- This is a lock to allow only one thread of control in the RTS at a
82 -- time; it is used to execute in mutual exclusion from all other tasks.
83 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
85 Environment_Task_Id
: Task_Id
;
86 -- A variable to hold Task_Id for the environment task
88 Unblocked_Signal_Mask
: aliased sigset_t
;
89 -- The set of signals that should unblocked in all tasks
91 -- The followings are internal configuration constants needed
93 Time_Slice_Val
: Integer;
94 pragma Import
(C
, Time_Slice_Val
, "__gl_time_slice_val");
96 Locking_Policy
: Character;
97 pragma Import
(C
, Locking_Policy
, "__gl_locking_policy");
99 Dispatching_Policy
: Character;
100 pragma Import
(C
, Dispatching_Policy
, "__gl_task_dispatching_policy");
102 Mutex_Protocol
: Priority_Type
;
104 Foreign_Task_Elaborated
: aliased Boolean := True;
105 -- Used to identified fake tasks (i.e., non-Ada Threads)
107 type Set_Stack_Limit_Proc_Acc
is access procedure;
108 pragma Convention
(C
, Set_Stack_Limit_Proc_Acc
);
110 Set_Stack_Limit_Hook
: Set_Stack_Limit_Proc_Acc
;
111 pragma Import
(C
, Set_Stack_Limit_Hook
, "__gnat_set_stack_limit_hook");
112 -- Procedure to be called when a task is created to set stack
121 procedure Initialize
;
122 pragma Inline
(Initialize
);
123 -- Initialize task specific data
125 function Is_Valid_Task
return Boolean;
126 pragma Inline
(Is_Valid_Task
);
127 -- Does executing thread have a TCB?
129 procedure Set
(Self_Id
: Task_Id
);
131 -- Set the self id for the current task
134 pragma Inline
(Delete
);
135 -- Delete the task specific data associated with the current task
137 function Self
return Task_Id
;
138 pragma Inline
(Self
);
139 -- Return a pointer to the Ada Task Control Block of the calling task
143 package body Specific
is separate;
144 -- The body of this package is target specific
146 ---------------------------------
147 -- Support for foreign threads --
148 ---------------------------------
150 function Register_Foreign_Thread
(Thread
: Thread_Id
) return Task_Id
;
151 -- Allocate and Initialize a new ATCB for the current Thread
153 function Register_Foreign_Thread
154 (Thread
: Thread_Id
) return Task_Id
is separate;
156 -----------------------
157 -- Local Subprograms --
158 -----------------------
160 procedure Abort_Handler
(signo
: Signal
);
161 -- Handler for the abort (SIGABRT) signal to handle asynchronous abort
163 procedure Install_Signal_Handlers
;
164 -- Install the default signal handlers for the current task
166 function To_Address
is
167 new Ada
.Unchecked_Conversion
(Task_Id
, System
.Address
);
173 procedure Abort_Handler
(signo
: Signal
) is
174 pragma Unreferenced
(signo
);
176 Self_ID
: constant Task_Id
:= Self
;
177 Old_Set
: aliased sigset_t
;
180 pragma Warnings
(Off
, Result
);
183 -- It is not safe to raise an exception when using ZCX and the GCC
184 -- exception handling mechanism.
186 if ZCX_By_Default
and then GCC_ZCX_Support
then
190 if Self_ID
.Deferral_Level
= 0
191 and then Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
192 and then not Self_ID
.Aborting
194 Self_ID
.Aborting
:= True;
196 -- Make sure signals used for RTS internal purpose are unmasked
201 Unblocked_Signal_Mask
'Access,
203 pragma Assert
(Result
= 0);
205 raise Standard
'Abort_Signal;
213 procedure Stack_Guard
(T
: ST
.Task_Id
; On
: Boolean) is
214 pragma Unreferenced
(T
);
215 pragma Unreferenced
(On
);
218 -- Nothing needed (why not???)
227 function Get_Thread_Id
(T
: ST
.Task_Id
) return OSI
.Thread_Id
is
229 return T
.Common
.LL
.Thread
;
236 function Self
return Task_Id
renames Specific
.Self
;
238 -----------------------------
239 -- Install_Signal_Handlers --
240 -----------------------------
242 procedure Install_Signal_Handlers
is
243 act
: aliased struct_sigaction
;
244 old_act
: aliased struct_sigaction
;
245 Tmp_Set
: aliased sigset_t
;
250 act
.sa_handler
:= Abort_Handler
'Address;
252 Result
:= sigemptyset
(Tmp_Set
'Access);
253 pragma Assert
(Result
= 0);
254 act
.sa_mask
:= Tmp_Set
;
258 (Signal
(Interrupt_Management
.Abort_Task_Interrupt
),
259 act
'Unchecked_Access,
260 old_act
'Unchecked_Access);
261 pragma Assert
(Result
= 0);
263 Interrupt_Management
.Initialize_Interrupts
;
264 end Install_Signal_Handlers
;
266 ---------------------
267 -- Initialize_Lock --
268 ---------------------
270 procedure Initialize_Lock
271 (Prio
: System
.Any_Priority
;
272 L
: not null access Lock
)
275 L
.Mutex
:= semMCreate
(SEM_Q_PRIORITY
+ SEM_INVERSION_SAFE
);
276 L
.Prio_Ceiling
:= int
(Prio
);
277 L
.Protocol
:= Mutex_Protocol
;
278 pragma Assert
(L
.Mutex
/= 0);
281 procedure Initialize_Lock
282 (L
: not null access RTS_Lock
;
285 pragma Unreferenced
(Level
);
287 L
.Mutex
:= semMCreate
(SEM_Q_PRIORITY
+ SEM_INVERSION_SAFE
);
288 L
.Prio_Ceiling
:= int
(System
.Any_Priority
'Last);
289 L
.Protocol
:= Mutex_Protocol
;
290 pragma Assert
(L
.Mutex
/= 0);
297 procedure Finalize_Lock
(L
: not null access Lock
) is
300 Result
:= semDelete
(L
.Mutex
);
301 pragma Assert
(Result
= 0);
304 procedure Finalize_Lock
(L
: not null access RTS_Lock
) is
307 Result
:= semDelete
(L
.Mutex
);
308 pragma Assert
(Result
= 0);
316 (L
: not null access Lock
;
317 Ceiling_Violation
: out Boolean)
322 if L
.Protocol
= Prio_Protect
323 and then int
(Self
.Common
.Current_Priority
) > L
.Prio_Ceiling
325 Ceiling_Violation
:= True;
328 Ceiling_Violation
:= False;
331 Result
:= semTake
(L
.Mutex
, WAIT_FOREVER
);
332 pragma Assert
(Result
= 0);
336 (L
: not null access RTS_Lock
;
337 Global_Lock
: Boolean := False)
341 if not Single_Lock
or else Global_Lock
then
342 Result
:= semTake
(L
.Mutex
, WAIT_FOREVER
);
343 pragma Assert
(Result
= 0);
347 procedure Write_Lock
(T
: Task_Id
) is
350 if not Single_Lock
then
351 Result
:= semTake
(T
.Common
.LL
.L
.Mutex
, WAIT_FOREVER
);
352 pragma Assert
(Result
= 0);
361 (L
: not null access Lock
;
362 Ceiling_Violation
: out Boolean)
365 Write_Lock
(L
, Ceiling_Violation
);
372 procedure Unlock
(L
: not null access Lock
) is
375 Result
:= semGive
(L
.Mutex
);
376 pragma Assert
(Result
= 0);
380 (L
: not null access RTS_Lock
;
381 Global_Lock
: Boolean := False)
385 if not Single_Lock
or else Global_Lock
then
386 Result
:= semGive
(L
.Mutex
);
387 pragma Assert
(Result
= 0);
391 procedure Unlock
(T
: Task_Id
) is
394 if not Single_Lock
then
395 Result
:= semGive
(T
.Common
.LL
.L
.Mutex
);
396 pragma Assert
(Result
= 0);
404 -- Dynamic priority ceilings are not supported by the underlying system
406 procedure Set_Ceiling
407 (L
: not null access Lock
;
408 Prio
: System
.Any_Priority
)
410 pragma Unreferenced
(L
, Prio
);
419 procedure Sleep
(Self_ID
: Task_Id
; Reason
: System
.Tasking
.Task_States
) is
420 pragma Unreferenced
(Reason
);
425 pragma Assert
(Self_ID
= Self
);
427 -- Release the mutex before sleeping
430 semGive
(if Single_Lock
431 then Single_RTS_Lock
.Mutex
432 else Self_ID
.Common
.LL
.L
.Mutex
);
433 pragma Assert
(Result
= 0);
435 -- Perform a blocking operation to take the CV semaphore. Note that a
436 -- blocking operation in VxWorks will reenable task scheduling. When we
437 -- are no longer blocked and control is returned, task scheduling will
438 -- again be disabled.
440 Result
:= semTake
(Self_ID
.Common
.LL
.CV
, WAIT_FOREVER
);
441 pragma Assert
(Result
= 0);
443 -- Take the mutex back
446 semTake
((if Single_Lock
447 then Single_RTS_Lock
.Mutex
448 else Self_ID
.Common
.LL
.L
.Mutex
), WAIT_FOREVER
);
449 pragma Assert
(Result
= 0);
456 -- This is for use within the run-time system, so abort is assumed to be
457 -- already deferred, and the caller should be holding its own ATCB lock.
459 procedure Timed_Sleep
462 Mode
: ST
.Delay_Modes
;
463 Reason
: System
.Tasking
.Task_States
;
464 Timedout
: out Boolean;
465 Yielded
: out Boolean)
467 pragma Unreferenced
(Reason
);
469 Orig
: constant Duration := Monotonic_Clock
;
473 Wakeup
: Boolean := False;
479 if Mode
= Relative
then
480 Absolute
:= Orig
+ Time
;
482 -- Systematically add one since the first tick will delay *at most*
483 -- 1 / Rate_Duration seconds, so we need to add one to be on the
486 Ticks
:= To_Clock_Ticks
(Time
);
488 if Ticks
> 0 and then Ticks
< int
'Last then
494 Ticks
:= To_Clock_Ticks
(Time
- Monotonic_Clock
);
499 -- Release the mutex before sleeping
502 semGive
(if Single_Lock
503 then Single_RTS_Lock
.Mutex
504 else Self_ID
.Common
.LL
.L
.Mutex
);
505 pragma Assert
(Result
= 0);
507 -- Perform a blocking operation to take the CV semaphore. Note
508 -- that a blocking operation in VxWorks will reenable task
509 -- scheduling. When we are no longer blocked and control is
510 -- returned, task scheduling will again be disabled.
512 Result
:= semTake
(Self_ID
.Common
.LL
.CV
, Ticks
);
516 -- Somebody may have called Wakeup for us
521 if errno
/= S_objLib_OBJ_TIMEOUT
then
525 -- If Ticks = int'last, it was most probably truncated so
526 -- let's make another round after recomputing Ticks from
527 -- the absolute time.
529 if Ticks
/= int
'Last then
533 Ticks
:= To_Clock_Ticks
(Absolute
- Monotonic_Clock
);
542 -- Take the mutex back
545 semTake
((if Single_Lock
546 then Single_RTS_Lock
.Mutex
547 else Self_ID
.Common
.LL
.L
.Mutex
), WAIT_FOREVER
);
548 pragma Assert
(Result
= 0);
550 exit when Timedout
or Wakeup
;
556 -- Should never hold a lock while yielding
559 Result
:= semGive
(Single_RTS_Lock
.Mutex
);
561 Result
:= semTake
(Single_RTS_Lock
.Mutex
, WAIT_FOREVER
);
564 Result
:= semGive
(Self_ID
.Common
.LL
.L
.Mutex
);
566 Result
:= semTake
(Self_ID
.Common
.LL
.L
.Mutex
, WAIT_FOREVER
);
575 -- This is for use in implementing delay statements, so we assume the
576 -- caller is holding no locks.
578 procedure Timed_Delay
581 Mode
: ST
.Delay_Modes
)
583 Orig
: constant Duration := Monotonic_Clock
;
587 Aborted
: Boolean := False;
590 pragma Warnings
(Off
, Result
);
593 if Mode
= Relative
then
594 Absolute
:= Orig
+ Time
;
595 Ticks
:= To_Clock_Ticks
(Time
);
597 if Ticks
> 0 and then Ticks
< int
'Last then
599 -- First tick will delay anytime between 0 and 1 / sysClkRateGet
600 -- seconds, so we need to add one to be on the safe side.
607 Ticks
:= To_Clock_Ticks
(Time
- Orig
);
612 -- Modifying State, locking the TCB
615 semTake
((if Single_Lock
616 then Single_RTS_Lock
.Mutex
617 else Self_ID
.Common
.LL
.L
.Mutex
), WAIT_FOREVER
);
619 pragma Assert
(Result
= 0);
621 Self_ID
.Common
.State
:= Delay_Sleep
;
625 Aborted
:= Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
;
627 -- Release the TCB before sleeping
630 semGive
(if Single_Lock
631 then Single_RTS_Lock
.Mutex
632 else Self_ID
.Common
.LL
.L
.Mutex
);
633 pragma Assert
(Result
= 0);
637 Result
:= semTake
(Self_ID
.Common
.LL
.CV
, Ticks
);
641 -- If Ticks = int'last, it was most probably truncated
642 -- so let's make another round after recomputing Ticks
643 -- from the absolute time.
645 if errno
= S_objLib_OBJ_TIMEOUT
and then Ticks
/= int
'Last then
648 Ticks
:= To_Clock_Ticks
(Absolute
- Monotonic_Clock
);
656 -- Take back the lock after having slept, to protect further
657 -- access to Self_ID.
662 then Single_RTS_Lock
.Mutex
663 else Self_ID
.Common
.LL
.L
.Mutex
), WAIT_FOREVER
);
665 pragma Assert
(Result
= 0);
670 Self_ID
.Common
.State
:= Runnable
;
675 then Single_RTS_Lock
.Mutex
676 else Self_ID
.Common
.LL
.L
.Mutex
);
683 ---------------------
684 -- Monotonic_Clock --
685 ---------------------
687 function Monotonic_Clock
return Duration is
688 TS
: aliased timespec
;
691 Result
:= clock_gettime
(CLOCK_REALTIME
, TS
'Unchecked_Access);
692 pragma Assert
(Result
= 0);
693 return To_Duration
(TS
);
700 function RT_Resolution
return Duration is
702 return 1.0 / Duration (sysClkRateGet
);
709 procedure Wakeup
(T
: Task_Id
; Reason
: System
.Tasking
.Task_States
) is
710 pragma Unreferenced
(Reason
);
713 Result
:= semGive
(T
.Common
.LL
.CV
);
714 pragma Assert
(Result
= 0);
721 procedure Yield
(Do_Yield
: Boolean := True) is
722 pragma Unreferenced
(Do_Yield
);
724 pragma Unreferenced
(Result
);
726 Result
:= taskDelay
(0);
733 procedure Set_Priority
735 Prio
: System
.Any_Priority
;
736 Loss_Of_Inheritance
: Boolean := False)
738 pragma Unreferenced
(Loss_Of_Inheritance
);
745 (T
.Common
.LL
.Thread
, To_VxWorks_Priority
(int
(Prio
)));
746 pragma Assert
(Result
= 0);
748 -- Note: in VxWorks 6.6 (or earlier), the task is placed at the end of
749 -- the priority queue instead of the head. This is not the behavior
750 -- required by Annex D (RM D.2.3(5/2)), but we consider it an acceptable
751 -- variation (RM 1.1.3(6)), given this is the built-in behavior of the
752 -- operating system. VxWorks versions starting from 6.7 implement the
753 -- required Annex D semantics.
755 -- In older versions we attempted to better approximate the Annex D
756 -- required behavior, but this simulation was not entirely accurate,
757 -- and it seems better to live with the standard VxWorks semantics.
759 T
.Common
.Current_Priority
:= Prio
;
766 function Get_Priority
(T
: Task_Id
) return System
.Any_Priority
is
768 return T
.Common
.Current_Priority
;
775 procedure Enter_Task
(Self_ID
: Task_Id
) is
776 procedure Init_Float
;
777 pragma Import
(C
, Init_Float
, "__gnat_init_float");
778 -- Properly initializes the FPU for PPC/MIPS systems
781 -- Store the user-level task id in the Thread field (to be used
782 -- internally by the run-time system) and the kernel-level task id in
783 -- the LWP field (to be used by the debugger).
785 Self_ID
.Common
.LL
.Thread
:= taskIdSelf
;
786 Self_ID
.Common
.LL
.LWP
:= getpid
;
788 Specific
.Set
(Self_ID
);
792 -- Install the signal handlers
794 -- This is called for each task since there is no signal inheritance
795 -- between VxWorks tasks.
797 Install_Signal_Handlers
;
799 -- If stack checking is enabled, set the stack limit for this task
801 if Set_Stack_Limit_Hook
/= null then
802 Set_Stack_Limit_Hook
.all;
810 function New_ATCB
(Entry_Num
: Task_Entry_Index
) return Task_Id
is
812 return new Ada_Task_Control_Block
(Entry_Num
);
819 function Is_Valid_Task
return Boolean renames Specific
.Is_Valid_Task
;
821 -----------------------------
822 -- Register_Foreign_Thread --
823 -----------------------------
825 function Register_Foreign_Thread
return Task_Id
is
827 if Is_Valid_Task
then
830 return Register_Foreign_Thread
(taskIdSelf
);
832 end Register_Foreign_Thread
;
838 procedure Initialize_TCB
(Self_ID
: Task_Id
; Succeeded
: out Boolean) is
840 Self_ID
.Common
.LL
.CV
:= semBCreate
(SEM_Q_PRIORITY
, SEM_EMPTY
);
841 Self_ID
.Common
.LL
.Thread
:= 0;
843 if Self_ID
.Common
.LL
.CV
= 0 then
849 if not Single_Lock
then
850 Initialize_Lock
(Self_ID
.Common
.LL
.L
'Access, ATCB_Level
);
859 procedure Create_Task
861 Wrapper
: System
.Address
;
862 Stack_Size
: System
.Parameters
.Size_Type
;
863 Priority
: System
.Any_Priority
;
864 Succeeded
: out Boolean)
866 Adjusted_Stack_Size
: size_t
;
869 use System
.Task_Info
;
872 -- Ask for four extra bytes of stack space so that the ATCB pointer can
873 -- be stored below the stack limit, plus extra space for the frame of
874 -- Task_Wrapper. This is so the user gets the amount of stack requested
875 -- exclusive of the needs.
877 -- We also have to allocate n more bytes for the task name storage and
878 -- enough space for the Wind Task Control Block which is around 0x778
879 -- bytes. VxWorks also seems to carve out additional space, so use 2048
880 -- as a nice round number. We might want to increment to the nearest
881 -- page size in case we ever support VxVMI.
883 -- ??? - we should come back and visit this so we can set the task name
884 -- to something appropriate.
886 Adjusted_Stack_Size
:= size_t
(Stack_Size
) + 2048;
888 -- Since the initial signal mask of a thread is inherited from the
889 -- creator, and the Environment task has all its signals masked, we do
890 -- not need to manipulate caller's signal mask at this point. All tasks
891 -- in RTS will have All_Tasks_Mask initially.
893 -- We now compute the VxWorks task name and options, then spawn ...
896 Name
: aliased String (1 .. T
.Common
.Task_Image_Len
+ 1);
897 Name_Address
: System
.Address
;
898 -- Task name we are going to hand down to VxWorks
900 function Get_Task_Options
return int
;
901 pragma Import
(C
, Get_Task_Options
, "__gnat_get_task_options");
902 -- Function that returns the options to be set for the task that we
903 -- are creating. We fetch the options assigned to the current task,
904 -- so offering some user level control over the options for a task
905 -- hierarchy, and force VX_FP_TASK because it is almost always
909 -- If there is no Ada task name handy, let VxWorks choose one.
910 -- Otherwise, tell VxWorks what the Ada task name is.
912 if T
.Common
.Task_Image_Len
= 0 then
913 Name_Address
:= System
.Null_Address
;
915 Name
(1 .. Name
'Last - 1) :=
916 T
.Common
.Task_Image
(1 .. T
.Common
.Task_Image_Len
);
917 Name
(Name
'Last) := ASCII
.NUL
;
918 Name_Address
:= Name
'Address;
921 -- Now spawn the VxWorks task for real
923 T
.Common
.LL
.Thread
:=
926 To_VxWorks_Priority
(int
(Priority
)),
933 -- Set processor affinity
935 if T
.Common
.Task_Info
/= Unspecified_Task_Info
then
937 taskCpuAffinitySet
(T
.Common
.LL
.Thread
, T
.Common
.Task_Info
);
940 taskDelete
(T
.Common
.LL
.Thread
);
941 T
.Common
.LL
.Thread
:= -1;
945 if T
.Common
.LL
.Thread
= -1 then
949 Task_Creation_Hook
(T
.Common
.LL
.Thread
);
950 Set_Priority
(T
, Priority
);
958 procedure Finalize_TCB
(T
: Task_Id
) is
961 Is_Self
: constant Boolean := (T
= Self
);
963 procedure Free
is new
964 Ada
.Unchecked_Deallocation
(Ada_Task_Control_Block
, Task_Id
);
967 if not Single_Lock
then
968 Result
:= semDelete
(T
.Common
.LL
.L
.Mutex
);
969 pragma Assert
(Result
= 0);
972 T
.Common
.LL
.Thread
:= 0;
974 Result
:= semDelete
(T
.Common
.LL
.CV
);
975 pragma Assert
(Result
= 0);
977 if T
.Known_Tasks_Index
/= -1 then
978 Known_Tasks
(T
.Known_Tasks_Index
) := null;
992 procedure Exit_Task
is
1001 procedure Abort_Task
(T
: Task_Id
) is
1006 (T
.Common
.LL
.Thread
,
1007 Signal
(Interrupt_Management
.Abort_Task_Interrupt
));
1008 pragma Assert
(Result
= 0);
1015 procedure Initialize
(S
: in out Suspension_Object
) is
1017 -- Initialize internal state (always to False (RM D.10(6)))
1022 -- Initialize internal mutex
1024 -- Use simpler binary semaphore instead of VxWorks
1025 -- mutual exclusion semaphore, because we don't need
1026 -- the fancier semantics and their overhead.
1028 S
.L
:= semBCreate
(SEM_Q_FIFO
, SEM_FULL
);
1030 -- Initialize internal condition variable
1032 S
.CV
:= semBCreate
(SEM_Q_FIFO
, SEM_EMPTY
);
1039 procedure Finalize
(S
: in out Suspension_Object
) is
1040 pragma Unmodified
(S
);
1041 -- S may be modified on other targets, but not on VxWorks
1046 -- Destroy internal mutex
1048 Result
:= semDelete
(S
.L
);
1049 pragma Assert
(Result
= OK
);
1051 -- Destroy internal condition variable
1053 Result
:= semDelete
(S
.CV
);
1054 pragma Assert
(Result
= OK
);
1061 function Current_State
(S
: Suspension_Object
) return Boolean is
1063 -- We do not want to use lock on this read operation. State is marked
1064 -- as Atomic so that we ensure that the value retrieved is correct.
1073 procedure Set_False
(S
: in out Suspension_Object
) is
1077 SSL
.Abort_Defer
.all;
1079 Result
:= semTake
(S
.L
, WAIT_FOREVER
);
1080 pragma Assert
(Result
= OK
);
1084 Result
:= semGive
(S
.L
);
1085 pragma Assert
(Result
= OK
);
1087 SSL
.Abort_Undefer
.all;
1094 procedure Set_True
(S
: in out Suspension_Object
) is
1098 SSL
.Abort_Defer
.all;
1100 Result
:= semTake
(S
.L
, WAIT_FOREVER
);
1101 pragma Assert
(Result
= OK
);
1103 -- If there is already a task waiting on this suspension object then
1104 -- we resume it, leaving the state of the suspension object to False,
1105 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1106 -- the state to True.
1112 Result
:= semGive
(S
.CV
);
1113 pragma Assert
(Result
= OK
);
1118 Result
:= semGive
(S
.L
);
1119 pragma Assert
(Result
= OK
);
1121 SSL
.Abort_Undefer
.all;
1124 ------------------------
1125 -- Suspend_Until_True --
1126 ------------------------
1128 procedure Suspend_Until_True
(S
: in out Suspension_Object
) is
1132 SSL
.Abort_Defer
.all;
1134 Result
:= semTake
(S
.L
, WAIT_FOREVER
);
1138 -- Program_Error must be raised upon calling Suspend_Until_True
1139 -- if another task is already waiting on that suspension object
1140 -- (ARM D.10 par. 10).
1142 Result
:= semGive
(S
.L
);
1143 pragma Assert
(Result
= OK
);
1145 SSL
.Abort_Undefer
.all;
1147 raise Program_Error
;
1150 -- Suspend the task if the state is False. Otherwise, the task
1151 -- continues its execution, and the state of the suspension object
1152 -- is set to False (ARM D.10 par. 9).
1157 Result
:= semGive
(S
.L
);
1158 pragma Assert
(Result
= 0);
1160 SSL
.Abort_Undefer
.all;
1165 -- Release the mutex before sleeping
1167 Result
:= semGive
(S
.L
);
1168 pragma Assert
(Result
= OK
);
1170 SSL
.Abort_Undefer
.all;
1172 Result
:= semTake
(S
.CV
, WAIT_FOREVER
);
1173 pragma Assert
(Result
= 0);
1176 end Suspend_Until_True
;
1184 function Check_Exit
(Self_ID
: ST
.Task_Id
) return Boolean is
1185 pragma Unreferenced
(Self_ID
);
1190 --------------------
1191 -- Check_No_Locks --
1192 --------------------
1194 function Check_No_Locks
(Self_ID
: ST
.Task_Id
) return Boolean is
1195 pragma Unreferenced
(Self_ID
);
1200 ----------------------
1201 -- Environment_Task --
1202 ----------------------
1204 function Environment_Task
return Task_Id
is
1206 return Environment_Task_Id
;
1207 end Environment_Task
;
1213 procedure Lock_RTS
is
1215 Write_Lock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1222 procedure Unlock_RTS
is
1224 Unlock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1231 function Suspend_Task
1233 Thread_Self
: Thread_Id
) return Boolean
1236 if T
.Common
.LL
.Thread
/= 0
1237 and then T
.Common
.LL
.Thread
/= Thread_Self
1239 return taskSuspend
(T
.Common
.LL
.Thread
) = 0;
1249 function Resume_Task
1251 Thread_Self
: Thread_Id
) return Boolean
1254 if T
.Common
.LL
.Thread
/= 0
1255 and then T
.Common
.LL
.Thread
/= Thread_Self
1257 return taskResume
(T
.Common
.LL
.Thread
) = 0;
1263 --------------------
1264 -- Stop_All_Tasks --
1265 --------------------
1267 procedure Stop_All_Tasks
1269 Thread_Self
: constant Thread_Id
:= taskIdSelf
;
1273 pragma Unreferenced
(Dummy
);
1278 C
:= All_Tasks_List
;
1279 while C
/= null loop
1280 if C
.Common
.LL
.Thread
/= 0
1281 and then C
.Common
.LL
.Thread
/= Thread_Self
1283 Dummy
:= Task_Stop
(C
.Common
.LL
.Thread
);
1286 C
:= C
.Common
.All_Tasks_Link
;
1289 Dummy
:= Int_Unlock
;
1296 function Stop_Task
(T
: ST
.Task_Id
) return Boolean is
1298 if T
.Common
.LL
.Thread
/= 0 then
1299 return Task_Stop
(T
.Common
.LL
.Thread
) = 0;
1309 function Continue_Task
(T
: ST
.Task_Id
) return Boolean
1312 if T
.Common
.LL
.Thread
/= 0 then
1313 return Task_Cont
(T
.Common
.LL
.Thread
) = 0;
1323 procedure Initialize
(Environment_Task
: Task_Id
) is
1327 Environment_Task_Id
:= Environment_Task
;
1329 Interrupt_Management
.Initialize
;
1330 Specific
.Initialize
;
1332 if Locking_Policy
= 'C' then
1333 Mutex_Protocol
:= Prio_Protect
;
1334 elsif Locking_Policy
= 'I' then
1335 Mutex_Protocol
:= Prio_Inherit
;
1337 Mutex_Protocol
:= Prio_None
;
1340 if Time_Slice_Val
> 0 then
1344 (Duration (Time_Slice_Val
) / Duration (1_000_000
.0
)));
1346 elsif Dispatching_Policy
= 'R' then
1347 Result
:= Set_Time_Slice
(To_Clock_Ticks
(0.01));
1351 Result
:= sigemptyset
(Unblocked_Signal_Mask
'Access);
1352 pragma Assert
(Result
= 0);
1354 for J
in Interrupt_Management
.Signal_ID
loop
1355 if System
.Interrupt_Management
.Keep_Unmasked
(J
) then
1356 Result
:= sigaddset
(Unblocked_Signal_Mask
'Access, Signal
(J
));
1357 pragma Assert
(Result
= 0);
1361 -- Initialize the lock used to synchronize chain of all ATCBs
1363 Initialize_Lock
(Single_RTS_Lock
'Access, RTS_Lock_Level
);
1365 -- Make environment task known here because it doesn't go through
1366 -- Activate_Tasks, which does it for all other tasks.
1368 Known_Tasks
(Known_Tasks
'First) := Environment_Task
;
1369 Environment_Task
.Known_Tasks_Index
:= Known_Tasks
'First;
1371 Enter_Task
(Environment_Task
);
1374 end System
.Task_Primitives
.Operations
;