diff options
Diffstat (limited to 'gcc/ada/s-taprop-vxworks.adb')
| -rw-r--r-- | gcc/ada/s-taprop-vxworks.adb | 109 |
1 files changed, 71 insertions, 38 deletions
diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index 2621c60a0b7..b0974a63486 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -45,7 +45,7 @@ with System.Tasking.Debug; with System.Interrupt_Management; -- used for Keep_Unmasked --- Abort_Task_Signal +-- Abort_Task_Interrupt -- Signal_ID -- Initialize_Interrupts @@ -59,8 +59,8 @@ with System.Soft_Links; -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. -with Unchecked_Conversion; -with Unchecked_Deallocation; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; package body System.Task_Primitives.Operations is @@ -165,7 +165,8 @@ package body System.Task_Primitives.Operations is procedure Install_Signal_Handlers; -- Install the default signal handlers for the current task - function To_Address is new Unchecked_Conversion (Task_Id, System.Address); + function To_Address is + new Ada.Unchecked_Conversion (Task_Id, System.Address); ------------------- -- Abort_Handler -- @@ -194,8 +195,11 @@ package body System.Task_Primitives.Operations is -- Make sure signals used for RTS internal purpose are unmasked - Result := pthread_sigmask (SIG_UNBLOCK, - Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); + Result := + pthread_sigmask + (SIG_UNBLOCK, + Unblocked_Signal_Mask'Unchecked_Access, + Old_Set'Unchecked_Access); pragma Assert (Result = 0); raise Standard'Abort_Signal; @@ -251,7 +255,7 @@ package body System.Task_Primitives.Operations is Result := sigaction - (Signal (Interrupt_Management.Abort_Task_Signal), + (Signal (Interrupt_Management.Abort_Task_Interrupt), act'Unchecked_Access, old_act'Unchecked_Access); pragma Assert (Result = 0); @@ -264,7 +268,9 @@ package body System.Task_Primitives.Operations is --------------------- procedure Initialize_Lock - (Prio : System.Any_Priority; L : not null access Lock) is + (Prio : System.Any_Priority; + L : not null access Lock) + is begin L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); L.Prio_Ceiling := int (Prio); @@ -273,10 +279,10 @@ package body System.Task_Primitives.Operations is end Initialize_Lock; procedure Initialize_Lock - (L : not null access RTS_Lock; Level : Lock_Level) + (L : not null access RTS_Lock; + Level : Lock_Level) is pragma Unreferenced (Level); - begin L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); L.Prio_Ceiling := int (System.Any_Priority'Last); @@ -307,9 +313,11 @@ package body System.Task_Primitives.Operations is ---------------- procedure Write_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean) + (L : not null access Lock; + Ceiling_Violation : out Boolean) is Result : int; + begin if L.Protocol = Prio_Protect and then int (Self.Common.Current_Priority) > L.Prio_Ceiling @@ -350,7 +358,9 @@ package body System.Task_Primitives.Operations is --------------- procedure Read_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean) is + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is begin Write_Lock (L, Ceiling_Violation); end Read_Lock; @@ -367,7 +377,8 @@ package body System.Task_Primitives.Operations is end Unlock; procedure Unlock - (L : not null access RTS_Lock; Global_Lock : Boolean := False) + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) is Result : int; begin @@ -386,6 +397,21 @@ package body System.Task_Primitives.Operations is end if; end Unlock; + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + ----------- -- Sleep -- ----------- @@ -508,6 +534,7 @@ package body System.Task_Primitives.Operations is if Ticks /= int'Last then Timedout := True; + else Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock); @@ -590,7 +617,7 @@ package body System.Task_Primitives.Operations is if Ticks > 0 then - -- Modifying State and Pending_Priority_Change, locking the TCB + -- Modifying State, locking the TCB if Single_Lock then Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); @@ -604,12 +631,6 @@ package body System.Task_Primitives.Operations is Timedout := False; loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - Aborted := Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; -- Release the TCB before sleeping @@ -745,7 +766,7 @@ package body System.Task_Primitives.Operations is and then Loss_Of_Inheritance and then Prio < T.Common.Current_Priority then - -- Annex D requirement [RM D.2.2 par. 9]: + -- Annex D requirement (RM D.2.2(9)) -- If the task drops its priority due to the loss of inherited -- priority, it is added at the head of the ready queue for its @@ -861,6 +882,7 @@ package body System.Task_Primitives.Operations is if Self_ID.Common.LL.CV = 0 then Succeeded := False; + else Succeeded := True; @@ -934,13 +956,14 @@ package body System.Task_Primitives.Operations is -- Now spawn the VxWorks task for real - T.Common.LL.Thread := taskSpawn - (Name_Address, - To_VxWorks_Priority (int (Priority)), - Get_Task_Options, - Adjusted_Stack_Size, - Wrapper, - To_Address (T)); + T.Common.LL.Thread := + taskSpawn + (Name_Address, + To_VxWorks_Priority (int (Priority)), + Get_Task_Options, + Adjusted_Stack_Size, + Wrapper, + To_Address (T)); end; if T.Common.LL.Thread = -1 then @@ -963,7 +986,7 @@ package body System.Task_Primitives.Operations is Is_Self : constant Boolean := (T = Self); procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); begin if not Single_Lock then @@ -1003,8 +1026,10 @@ package body System.Task_Primitives.Operations is procedure Abort_Task (T : Task_Id) is Result : int; begin - Result := kill (T.Common.LL.Thread, - Signal (Interrupt_Management.Abort_Task_Signal)); + Result := + kill + (T.Common.LL.Thread, + Signal (Interrupt_Management.Abort_Task_Interrupt)); pragma Assert (Result = 0); end Abort_Task; @@ -1014,8 +1039,7 @@ package body System.Task_Primitives.Operations is procedure Initialize (S : in out Suspension_Object) is begin - -- Initialize internal state. It is always initialized to False (ARM - -- D.10 par. 6). + -- Initialize internal state (always to False (RM D.10(6))) S.State := False; S.Waiting := False; @@ -1039,6 +1063,7 @@ package body System.Task_Primitives.Operations is procedure Finalize (S : in out Suspension_Object) is Result : STATUS; + begin -- Destroy internal mutex @@ -1068,7 +1093,8 @@ package body System.Task_Primitives.Operations is --------------- procedure Set_False (S : in out Suspension_Object) is - Result : STATUS; + Result : STATUS; + begin SSL.Abort_Defer.all; @@ -1089,6 +1115,7 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : STATUS; + begin SSL.Abort_Defer.all; @@ -1122,12 +1149,14 @@ package body System.Task_Primitives.Operations is procedure Suspend_Until_True (S : in out Suspension_Object) is Result : STATUS; + begin SSL.Abort_Defer.all; Result := semTake (S.L, WAIT_FOREVER); if S.Waiting then + -- Program_Error must be raised upon calling Suspend_Until_True -- if another task is already waiting on that suspension object -- (ARM D.10 par. 10). @@ -1138,6 +1167,7 @@ package body System.Task_Primitives.Operations is SSL.Abort_Undefer.all; raise Program_Error; + else -- Suspend the task if the state is False. Otherwise, the task -- continues its execution, and the state of the suspension object @@ -1150,6 +1180,7 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); SSL.Abort_Undefer.all; + else S.Waiting := True; @@ -1257,6 +1288,7 @@ package body System.Task_Primitives.Operations is procedure Initialize (Environment_Task : Task_Id) is Result : int; + begin Environment_Task_Id := Environment_Task; @@ -1272,9 +1304,10 @@ package body System.Task_Primitives.Operations is end if; if Time_Slice_Val > 0 then - Result := Set_Time_Slice - (To_Clock_Ticks - (Duration (Time_Slice_Val) / Duration (1_000_000.0))); + Result := + Set_Time_Slice + (To_Clock_Ticks + (Duration (Time_Slice_Val) / Duration (1_000_000.0))); elsif Dispatching_Policy = 'R' then Result := Set_Time_Slice (To_Clock_Ticks (0.01)); |