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