1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- A D A . D Y N A M I C _ P R I O R I T I E S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- 10-- -- 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. -- 17-- -- 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. -- 21-- -- 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/>. -- 26-- -- 27-- GNARL was developed by the GNARL team at Florida State University. -- 28-- Extensive contributions were provided by Ada Core Technologies, Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with System.Task_Primitives.Operations; 33with System.Tasking; 34with System.Parameters; 35with System.Soft_Links; 36 37with Ada.Unchecked_Conversion; 38 39package body Ada.Dynamic_Priorities is 40 41 package STPO renames System.Task_Primitives.Operations; 42 package SSL renames System.Soft_Links; 43 44 use System.Parameters; 45 use System.Tasking; 46 47 function Convert_Ids is new 48 Ada.Unchecked_Conversion 49 (Task_Identification.Task_Id, System.Tasking.Task_Id); 50 51 ------------------ 52 -- Get_Priority -- 53 ------------------ 54 55 -- Inquire base priority of a task 56 57 function Get_Priority 58 (T : Ada.Task_Identification.Task_Id := 59 Ada.Task_Identification.Current_Task) return System.Any_Priority 60 is 61 Target : constant Task_Id := Convert_Ids (T); 62 Error_Message : constant String := "Trying to get the priority of a "; 63 64 begin 65 if Target = Convert_Ids (Ada.Task_Identification.Null_Task_Id) then 66 raise Program_Error with Error_Message & "null task"; 67 end if; 68 69 if Task_Identification.Is_Terminated (T) then 70 raise Tasking_Error with Error_Message & "terminated task"; 71 end if; 72 73 return Target.Common.Base_Priority; 74 end Get_Priority; 75 76 ------------------ 77 -- Set_Priority -- 78 ------------------ 79 80 -- Change base priority of a task dynamically 81 82 procedure Set_Priority 83 (Priority : System.Any_Priority; 84 T : Ada.Task_Identification.Task_Id := 85 Ada.Task_Identification.Current_Task) 86 is 87 Target : constant Task_Id := Convert_Ids (T); 88 Error_Message : constant String := "Trying to set the priority of a "; 89 Yield_Needed : Boolean; 90 91 begin 92 if Target = Convert_Ids (Ada.Task_Identification.Null_Task_Id) then 93 raise Program_Error with Error_Message & "null task"; 94 end if; 95 96 -- Setting the priority of an already-terminated task doesn't do 97 -- anything (see RM-D.5.1(7)). Note that Get_Priority is different in 98 -- this regard. 99 100 if Task_Identification.Is_Terminated (T) then 101 return; 102 end if; 103 104 SSL.Abort_Defer.all; 105 106 if Single_Lock then 107 STPO.Lock_RTS; 108 end if; 109 110 STPO.Write_Lock (Target); 111 112 Target.Common.Base_Priority := Priority; 113 114 if Target.Common.Call /= null 115 and then 116 Target.Common.Call.Acceptor_Prev_Priority /= Priority_Not_Boosted 117 then 118 -- Target is within a rendezvous, so ensure the correct priority 119 -- will be reset when finishing the rendezvous, and only change the 120 -- priority immediately if the new priority is greater than the 121 -- current (inherited) priority. 122 123 Target.Common.Call.Acceptor_Prev_Priority := Priority; 124 125 if Priority >= Target.Common.Current_Priority then 126 Yield_Needed := True; 127 STPO.Set_Priority (Target, Priority); 128 else 129 Yield_Needed := False; 130 end if; 131 132 else 133 Yield_Needed := True; 134 STPO.Set_Priority (Target, Priority); 135 136 if Target.Common.State = Entry_Caller_Sleep then 137 Target.Pending_Priority_Change := True; 138 STPO.Wakeup (Target, Target.Common.State); 139 end if; 140 end if; 141 142 STPO.Unlock (Target); 143 144 if Single_Lock then 145 STPO.Unlock_RTS; 146 end if; 147 148 if STPO.Self = Target and then Yield_Needed then 149 150 -- Yield is needed to enforce FIFO task dispatching 151 152 -- LL Set_Priority is made while holding the RTS lock so that it is 153 -- inheriting high priority until it release all the RTS locks. 154 155 -- If this is used in a system where Ceiling Locking is not enforced 156 -- we may end up getting two Yield effects. 157 158 STPO.Yield; 159 end if; 160 161 SSL.Abort_Undefer.all; 162 end Set_Priority; 163 164end Ada.Dynamic_Priorities; 165