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-2002, 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. It is --
31 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
35 -- This is the VxWorks version of this package
37 -- This package contains all the GNULL primitives that interface directly
38 -- with the underlying OS.
41 -- Turn off polling, we do not want ATC polling to take place during
42 -- tasking operations. It causes infinite loops and other problems.
44 with System.Tasking.Debug;
45 -- used for Known_Tasks
47 with System.Interrupt_Management;
48 -- used for Keep_Unmasked
49 -- Abort_Task_Interrupt
51 -- Initialize_Interrupts
53 with System.Soft_Links;
54 -- used for Defer/Undefer_Abort
56 -- Note that we do not use System.Tasking.Initialization directly since
57 -- this is a higher level package that we shouldn't depend on. For example
58 -- when using the restricted run time, it is replaced by
59 -- System.Tasking.Restricted.Initialization
61 with System.OS_Interface;
62 -- used for various type, constant, and operations
64 with System.Parameters;
68 -- used for Ada_Task_Control_Block
70 -- ATCB components and types
72 with System.Task_Info;
73 -- used for Task_Image
77 with Unchecked_Conversion;
78 with Unchecked_Deallocation;
80 package body System.Task_Primitives.Operations is
82 use System.Tasking.Debug;
85 use System.OS_Interface;
86 use System.Parameters;
87 use type Interfaces.C.int;
89 package SSL renames System.Soft_Links;
91 subtype int is System.OS_Interface.int;
93 Relative : constant := 0;
99 -- The followings are logically constants, but need to be initialized
102 Current_Task : aliased Task_ID;
103 pragma Export (Ada, Current_Task);
104 -- Task specific value used to store the Ada Task_ID.
106 Single_RTS_Lock : aliased RTS_Lock;
107 -- This is a lock to allow only one thread of control in the RTS at
108 -- a time; it is used to execute in mutual exclusion from all other tasks.
109 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
111 Environment_Task_ID : Task_ID;
112 -- A variable to hold Task_ID for the environment task.
114 Unblocked_Signal_Mask : aliased sigset_t;
115 -- The set of signals that should unblocked in all tasks
117 -- The followings are internal configuration constants needed.
119 Time_Slice_Val : Integer;
120 pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
122 Locking_Policy : Character;
123 pragma Import (C, Locking_Policy, "__gl_locking_policy");
125 Dispatching_Policy : Character;
126 pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
128 FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
129 -- Indicates whether FIFO_Within_Priorities is set.
131 Mutex_Protocol : Priority_Type;
133 -----------------------
134 -- Local Subprograms --
135 -----------------------
137 procedure Abort_Handler (signo : Signal);
139 function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
145 procedure Abort_Handler (signo : Signal) is
146 Self_ID : constant Task_ID := Self;
148 Old_Set : aliased sigset_t;
151 if Self_ID.Deferral_Level = 0
152 and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
153 and then not Self_ID.Aborting
155 Self_ID.Aborting := True;
157 -- Make sure signals used for RTS internal purpose are unmasked
159 Result := pthread_sigmask (SIG_UNBLOCK,
160 Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
161 pragma Assert (Result = 0);
163 raise Standard'Abort_Signal;
171 procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
181 function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
183 return T.Common.LL.Thread;
190 function Self return Task_ID is
192 pragma Assert (Current_Task /= null);
196 -----------------------------
197 -- Install_Signal_Handlers --
198 -----------------------------
200 procedure Install_Signal_Handlers;
201 -- Install the default signal handlers for the current task.
203 procedure Install_Signal_Handlers is
204 act : aliased struct_sigaction;
205 old_act : aliased struct_sigaction;
206 Tmp_Set : aliased sigset_t;
211 act.sa_handler := Abort_Handler'Address;
213 Result := sigemptyset (Tmp_Set'Access);
214 pragma Assert (Result = 0);
215 act.sa_mask := Tmp_Set;
219 (Signal (Interrupt_Management.Abort_Task_Interrupt),
220 act'Unchecked_Access,
221 old_act'Unchecked_Access);
222 pragma Assert (Result = 0);
224 Interrupt_Management.Initialize_Interrupts;
225 end Install_Signal_Handlers;
227 ---------------------
228 -- Initialize_Lock --
229 ---------------------
231 procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is
233 L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
234 L.Prio_Ceiling := int (Prio);
235 L.Protocol := Mutex_Protocol;
236 pragma Assert (L.Mutex /= 0);
239 procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
241 L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
242 L.Prio_Ceiling := int (System.Any_Priority'Last);
243 L.Protocol := Mutex_Protocol;
244 pragma Assert (L.Mutex /= 0);
251 procedure Finalize_Lock (L : access Lock) is
254 Result := semDelete (L.Mutex);
255 pragma Assert (Result = 0);
258 procedure Finalize_Lock (L : access RTS_Lock) is
261 Result := semDelete (L.Mutex);
262 pragma Assert (Result = 0);
269 procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
272 if L.Protocol = Prio_Protect
273 and then int (Self.Common.Current_Priority) > L.Prio_Ceiling
275 Ceiling_Violation := True;
278 Ceiling_Violation := False;
281 Result := semTake (L.Mutex, WAIT_FOREVER);
282 pragma Assert (Result = 0);
286 (L : access RTS_Lock; Global_Lock : Boolean := False)
290 if not Single_Lock or else Global_Lock then
291 Result := semTake (L.Mutex, WAIT_FOREVER);
292 pragma Assert (Result = 0);
296 procedure Write_Lock (T : Task_ID) is
299 if not Single_Lock then
300 Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER);
301 pragma Assert (Result = 0);
309 procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
311 Write_Lock (L, Ceiling_Violation);
318 procedure Unlock (L : access Lock) is
321 Result := semGive (L.Mutex);
322 pragma Assert (Result = 0);
325 procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
328 if not Single_Lock or else Global_Lock then
329 Result := semGive (L.Mutex);
330 pragma Assert (Result = 0);
334 procedure Unlock (T : Task_ID) is
337 if not Single_Lock then
338 Result := semGive (T.Common.LL.L.Mutex);
339 pragma Assert (Result = 0);
347 procedure Sleep (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is
350 pragma Assert (Self_ID = Self);
352 -- Disable task scheduling.
356 -- Release the mutex before sleeping.
359 Result := semGive (Single_RTS_Lock.Mutex);
361 Result := semGive (Self_ID.Common.LL.L.Mutex);
364 pragma Assert (Result = 0);
366 -- Indicate that there is another thread waiting on the CV.
368 Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting + 1;
370 -- Perform a blocking operation to take the CV semaphore.
371 -- Note that a blocking operation in VxWorks will reenable
372 -- task scheduling. When we are no longer blocked and control
373 -- is returned, task scheduling will again be disabled.
375 Result := semTake (Self_ID.Common.LL.CV.Sem, WAIT_FOREVER);
378 Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting - 1;
379 pragma Assert (False);
382 -- Take the mutex back.
385 Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
387 Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
390 pragma Assert (Result = 0);
392 -- Reenable task scheduling.
394 Result := taskUnlock;
401 -- This is for use within the run-time system, so abort is
402 -- assumed to be already deferred, and the caller should be
403 -- holding its own ATCB lock.
405 procedure Timed_Sleep
408 Mode : ST.Delay_Modes;
409 Reason : System.Tasking.Task_States;
410 Timedout : out Boolean;
411 Yielded : out Boolean)
420 if Mode = Relative then
421 -- Systematically add one since the first tick will delay
422 -- *at most* 1 / Rate_Duration seconds, so we need to add one to
423 -- be on the safe side.
425 Ticks := To_Clock_Ticks (Time) + 1;
427 Ticks := To_Clock_Ticks (Time - Monotonic_Clock);
431 -- Disable task scheduling.
435 -- Release the mutex before sleeping.
438 Result := semGive (Single_RTS_Lock.Mutex);
440 Result := semGive (Self_ID.Common.LL.L.Mutex);
443 pragma Assert (Result = 0);
445 -- Indicate that there is another thread waiting on the CV.
447 Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting + 1;
449 -- Perform a blocking operation to take the CV semaphore.
450 -- Note that a blocking operation in VxWorks will reenable
451 -- task scheduling. When we are no longer blocked and control
452 -- is returned, task scheduling will again be disabled.
454 Result := semTake (Self_ID.Common.LL.CV.Sem, Ticks);
457 -- Somebody may have called Wakeup for us
462 Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting - 1;
464 if errno /= S_objLib_OBJ_TIMEOUT then
469 -- Take the mutex back.
472 Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
474 Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
477 pragma Assert (Result = 0);
479 -- Reenable task scheduling.
481 Result := taskUnlock;
492 -- This is for use in implementing delay statements, so
493 -- we assume the caller is holding no locks.
495 procedure Timed_Delay
498 Mode : ST.Delay_Modes)
500 Orig : constant Duration := Monotonic_Clock;
510 Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
512 Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
515 pragma Assert (Result = 0);
517 if Mode = Relative then
518 Absolute := Orig + Time;
520 Ticks := To_Clock_Ticks (Time);
523 -- The first tick will delay anytime between 0 and
524 -- 1 / sysClkRateGet seconds, so we need to add one to
525 -- be on the safe side.
531 Ticks := To_Clock_Ticks (Time - Orig);
535 Self_ID.Common.State := Delay_Sleep;
538 if Self_ID.Pending_Priority_Change then
539 Self_ID.Pending_Priority_Change := False;
540 Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
541 Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
544 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
550 Result := semGive (Single_RTS_Lock.Mutex);
552 Result := semGive (Self_ID.Common.LL.L.Mutex);
555 pragma Assert (Result = 0);
557 -- Indicate that there is another thread waiting on the CV.
559 Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting + 1;
561 Result := semTake (Self_ID.Common.LL.CV.Sem, Ticks);
564 Self_ID.Common.LL.CV.Waiting :=
565 Self_ID.Common.LL.CV.Waiting - 1;
567 if errno = S_objLib_OBJ_TIMEOUT then
570 Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock);
575 Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
577 Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
580 pragma Assert (Result = 0);
582 -- Reenable task scheduling.
584 Result := taskUnlock;
589 Self_ID.Common.State := Runnable;
595 Result := semGive (Single_RTS_Lock.Mutex);
597 Result := semGive (Self_ID.Common.LL.L.Mutex);
600 pragma Assert (Result = 0);
601 SSL.Abort_Undefer.all;
604 ---------------------
605 -- Monotonic_Clock --
606 ---------------------
608 function Monotonic_Clock return Duration is
609 TS : aliased timespec;
613 Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
614 pragma Assert (Result = 0);
615 return To_Duration (TS);
622 function RT_Resolution return Duration is
631 procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
634 -- Disable task scheduling.
638 -- Iff someone is currently waiting on the condition variable
639 -- then release the semaphore; we don't want to leave the
640 -- semaphore in the full state because the next guy to do
641 -- a condition wait operation would not block.
643 if T.Common.LL.CV.Waiting > 0 then
644 Result := semGive (T.Common.LL.CV.Sem);
646 -- One less thread waiting on the CV.
648 T.Common.LL.CV.Waiting := T.Common.LL.CV.Waiting - 1;
650 pragma Assert (Result = 0);
653 -- Reenable task scheduling.
655 Result := taskUnlock;
662 procedure Yield (Do_Yield : Boolean := True) is
665 Result := taskDelay (0);
672 type Prio_Array_Type is array (System.Any_Priority) of Integer;
673 pragma Atomic_Components (Prio_Array_Type);
675 Prio_Array : Prio_Array_Type;
676 -- Global array containing the id of the currently running task for
679 -- Note: we assume that we are on a single processor with run-til-blocked
682 procedure Set_Priority
684 Prio : System.Any_Priority;
685 Loss_Of_Inheritance : Boolean := False)
687 Array_Item : Integer;
691 Result := taskPrioritySet
692 (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio)));
693 pragma Assert (Result = 0);
695 if FIFO_Within_Priorities then
696 -- Annex D requirement [RM D.2.2 par. 9]:
697 -- If the task drops its priority due to the loss of inherited
698 -- priority, it is added at the head of the ready queue for its
699 -- new active priority.
701 if Loss_Of_Inheritance
702 and then Prio < T.Common.Current_Priority
704 Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
705 Prio_Array (T.Common.Base_Priority) := Array_Item;
708 -- Let some processes a chance to arrive
712 -- Then wait for our turn to proceed
714 exit when Array_Item = Prio_Array (T.Common.Base_Priority)
715 or else Prio_Array (T.Common.Base_Priority) = 1;
718 Prio_Array (T.Common.Base_Priority) :=
719 Prio_Array (T.Common.Base_Priority) - 1;
723 T.Common.Current_Priority := Prio;
730 function Get_Priority (T : Task_ID) return System.Any_Priority is
732 return T.Common.Current_Priority;
739 procedure Enter_Task (Self_ID : Task_ID) is
742 procedure Init_Float;
743 pragma Import (C, Init_Float, "__gnat_init_float");
744 -- Properly initializes the FPU for PPC/MIPS systems.
747 Self_ID.Common.LL.Thread := taskIdSelf;
748 Result := taskVarAdd (0, Current_Task'Address);
749 Current_Task := Self_ID;
752 -- Install the signal handlers.
753 -- This is called for each task since there is no signal inheritance
754 -- between VxWorks tasks.
756 Install_Signal_Handlers;
760 for J in Known_Tasks'Range loop
761 if Known_Tasks (J) = null then
762 Known_Tasks (J) := Self_ID;
763 Self_ID.Known_Tasks_Index := J;
775 function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
777 return new Ada_Task_Control_Block (Entry_Num);
784 procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
786 Self_ID.Common.LL.CV.Sem := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY);
787 Self_ID.Common.LL.CV.Waiting := 0;
788 Self_ID.Common.LL.Thread := 0;
790 if Self_ID.Common.LL.CV.Sem = 0 then
795 if not Single_Lock then
796 Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
805 procedure Create_Task
807 Wrapper : System.Address;
808 Stack_Size : System.Parameters.Size_Type;
809 Priority : System.Any_Priority;
810 Succeeded : out Boolean)
812 use type System.Task_Info.Task_Image_Type;
814 Adjusted_Stack_Size : size_t;
817 if Stack_Size = Unspecified_Size then
818 Adjusted_Stack_Size := size_t (Default_Stack_Size);
820 elsif Stack_Size < Minimum_Stack_Size then
821 Adjusted_Stack_Size := size_t (Minimum_Stack_Size);
824 Adjusted_Stack_Size := size_t (Stack_Size);
827 -- Ask for 4 extra bytes of stack space so that the ATCB
828 -- pointer can be stored below the stack limit, plus extra
829 -- space for the frame of Task_Wrapper. This is so the user
830 -- gets the amount of stack requested exclusive of the needs
833 -- We also have to allocate n more bytes for the task name
834 -- storage and enough space for the Wind Task Control Block
835 -- which is around 0x778 bytes. VxWorks also seems to carve out
836 -- additional space, so use 2048 as a nice round number.
837 -- We might want to increment to the nearest page size in
838 -- case we ever support VxVMI.
840 -- XXX - we should come back and visit this so we can
841 -- set the task name to something appropriate.
842 Adjusted_Stack_Size := Adjusted_Stack_Size + 2048;
844 -- Since the initial signal mask of a thread is inherited from the
845 -- creator, and the Environment task has all its signals masked, we
846 -- do not need to manipulate caller's signal mask at this point.
847 -- All tasks in RTS will have All_Tasks_Mask initially.
849 if T.Common.Task_Image = null then
850 T.Common.LL.Thread := taskSpawn
851 (System.Null_Address,
852 To_VxWorks_Priority (int (Priority)),
859 Name : aliased String (1 .. T.Common.Task_Image'Length + 1);
861 Name (1 .. Name'Last - 1) := T.Common.Task_Image.all;
862 Name (Name'Last) := ASCII.NUL;
864 T.Common.LL.Thread := taskSpawn
866 To_VxWorks_Priority (int (Priority)),
874 if T.Common.LL.Thread = -1 then
880 Task_Creation_Hook (T.Common.LL.Thread);
881 Set_Priority (T, Priority);
888 procedure Finalize_TCB (T : Task_ID) is
892 procedure Free is new
893 Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
897 Result := semDelete (T.Common.LL.L.Mutex);
898 pragma Assert (Result = 0);
901 T.Common.LL.Thread := 0;
903 Result := semDelete (T.Common.LL.CV.Sem);
904 pragma Assert (Result = 0);
906 if T.Known_Tasks_Index /= -1 then
907 Known_Tasks (T.Known_Tasks_Index) := null;
917 procedure Exit_Task is
919 Task_Termination_Hook;
927 procedure Abort_Task (T : Task_ID) is
930 Result := kill (T.Common.LL.Thread,
931 Signal (Interrupt_Management.Abort_Task_Interrupt));
932 pragma Assert (Result = 0);
939 -- Dummy versions. The only currently working version is for solaris
942 function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
951 function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
956 ----------------------
957 -- Environment_Task --
958 ----------------------
960 function Environment_Task return Task_ID is
962 return Environment_Task_ID;
963 end Environment_Task;
969 procedure Lock_RTS is
971 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
978 procedure Unlock_RTS is
980 Unlock (Single_RTS_Lock'Access, Global_Lock => True);
987 function Suspend_Task
989 Thread_Self : Thread_Id) return Boolean is
991 if T.Common.LL.Thread /= 0
992 and then T.Common.LL.Thread /= Thread_Self
994 return taskSuspend (T.Common.LL.Thread) = 0;
1004 function Resume_Task
1006 Thread_Self : Thread_Id) return Boolean is
1008 if T.Common.LL.Thread /= 0
1009 and then T.Common.LL.Thread /= Thread_Self
1011 return taskResume (T.Common.LL.Thread) = 0;
1021 procedure Initialize (Environment_Task : Task_ID) is
1023 Environment_Task_ID := Environment_Task;
1025 -- Initialize the lock used to synchronize chain of all ATCBs.
1027 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1029 Enter_Task (Environment_Task);
1036 if Locking_Policy = 'C' then
1037 Mutex_Protocol := Prio_Protect;
1038 elsif Locking_Policy = 'I' then
1039 Mutex_Protocol := Prio_Inherit;
1041 Mutex_Protocol := Prio_None;
1044 if Time_Slice_Val > 0 then
1045 Result := kernelTimeSlice
1047 (Duration (Time_Slice_Val) / Duration (1_000_000.0)));
1050 Result := sigemptyset (Unblocked_Signal_Mask'Access);
1051 pragma Assert (Result = 0);
1053 end System.Task_Primitives.Operations;