1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1991-1994, Florida State University -- 10-- Copyright (C) 1995-2011, AdaCore -- 11-- -- 12-- GNAT 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 3, or (at your option) any later ver- -- 15-- sion. GNAT 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. -- 18-- -- 19-- As a special exception under Section 7 of GPL version 3, you are granted -- 20-- additional permissions described in the GCC Runtime Library Exception, -- 21-- version 3.1, as published by the Free Software Foundation. -- 22-- -- 23-- You should have received a copy of the GNU General Public License and -- 24-- a copy of the GCC Runtime Library Exception along with this program; -- 25-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26-- <http://www.gnu.org/licenses/>. -- 27-- -- 28-- GNARL was developed by the GNARL team at Florida State University. -- 29-- Extensive contributions were provided by Ada Core Technologies, Inc. -- 30-- -- 31------------------------------------------------------------------------------ 32 33pragma Polling (Off); 34-- Turn off polling, we do not want ATC polling to take place during 35-- tasking operations. It causes infinite loops and other problems. 36 37with System.Task_Primitives.Operations; 38with System.Parameters; 39with System.Traces; 40with System.Soft_Links.Tasking; 41 42package body System.Tasking.Protected_Objects is 43 44 use System.Task_Primitives.Operations; 45 use System.Traces; 46 47 ---------------- 48 -- Local Data -- 49 ---------------- 50 51 Locking_Policy : Character; 52 pragma Import (C, Locking_Policy, "__gl_locking_policy"); 53 54 ------------------------- 55 -- Finalize_Protection -- 56 ------------------------- 57 58 procedure Finalize_Protection (Object : in out Protection) is 59 begin 60 Finalize_Lock (Object.L'Unrestricted_Access); 61 end Finalize_Protection; 62 63 --------------------------- 64 -- Initialize_Protection -- 65 --------------------------- 66 67 procedure Initialize_Protection 68 (Object : Protection_Access; 69 Ceiling_Priority : Integer) 70 is 71 Init_Priority : Integer := Ceiling_Priority; 72 73 begin 74 if Init_Priority = Unspecified_Priority then 75 Init_Priority := System.Priority'Last; 76 end if; 77 78 Initialize_Lock (Init_Priority, Object.L'Access); 79 Object.Ceiling := System.Any_Priority (Init_Priority); 80 Object.New_Ceiling := System.Any_Priority (Init_Priority); 81 Object.Owner := Null_Task; 82 end Initialize_Protection; 83 84 ----------------- 85 -- Get_Ceiling -- 86 ----------------- 87 88 function Get_Ceiling 89 (Object : Protection_Access) return System.Any_Priority is 90 begin 91 return Object.New_Ceiling; 92 end Get_Ceiling; 93 94 ---------- 95 -- Lock -- 96 ---------- 97 98 procedure Lock (Object : Protection_Access) is 99 Ceiling_Violation : Boolean; 100 101 begin 102 -- The lock is made without deferring abort 103 104 -- Therefore the abort has to be deferred before calling this routine. 105 -- This means that the compiler has to generate a Defer_Abort call 106 -- before the call to Lock. 107 108 -- The caller is responsible for undeferring abort, and compiler 109 -- generated calls must be protected with cleanup handlers to ensure 110 -- that abort is undeferred in all cases. 111 112 -- If pragma Detect_Blocking is active then, as described in the ARM 113 -- 9.5.1, par. 15, we must check whether this is an external call on a 114 -- protected subprogram with the same target object as that of the 115 -- protected action that is currently in progress (i.e., if the caller 116 -- is already the protected object's owner). If this is the case hence 117 -- Program_Error must be raised. 118 119 if Detect_Blocking and then Object.Owner = Self then 120 raise Program_Error; 121 end if; 122 123 Write_Lock (Object.L'Access, Ceiling_Violation); 124 125 if Parameters.Runtime_Traces then 126 Send_Trace_Info (PO_Lock); 127 end if; 128 129 if Ceiling_Violation then 130 raise Program_Error; 131 end if; 132 133 -- We are entering in a protected action, so that we increase the 134 -- protected object nesting level (if pragma Detect_Blocking is 135 -- active), and update the protected object's owner. 136 137 if Detect_Blocking then 138 declare 139 Self_Id : constant Task_Id := Self; 140 begin 141 -- Update the protected object's owner 142 143 Object.Owner := Self_Id; 144 145 -- Increase protected object nesting level 146 147 Self_Id.Common.Protected_Action_Nesting := 148 Self_Id.Common.Protected_Action_Nesting + 1; 149 end; 150 end if; 151 end Lock; 152 153 -------------------- 154 -- Lock_Read_Only -- 155 -------------------- 156 157 procedure Lock_Read_Only (Object : Protection_Access) is 158 Ceiling_Violation : Boolean; 159 160 begin 161 -- If pragma Detect_Blocking is active then, as described in the ARM 162 -- 9.5.1, par. 15, we must check whether this is an external call on 163 -- protected subprogram with the same target object as that of the 164 -- protected action that is currently in progress (i.e., if the caller 165 -- is already the protected object's owner). If this is the case hence 166 -- Program_Error must be raised. 167 -- 168 -- Note that in this case (getting read access), several tasks may have 169 -- read ownership of the protected object, so that this method of 170 -- storing the (single) protected object's owner does not work reliably 171 -- for read locks. However, this is the approach taken for two major 172 -- reasons: first, this function is not currently being used (it is 173 -- provided for possible future use), and second, it largely simplifies 174 -- the implementation. 175 176 if Detect_Blocking and then Object.Owner = Self then 177 raise Program_Error; 178 end if; 179 180 Read_Lock (Object.L'Access, Ceiling_Violation); 181 182 if Parameters.Runtime_Traces then 183 Send_Trace_Info (PO_Lock); 184 end if; 185 186 if Ceiling_Violation then 187 raise Program_Error; 188 end if; 189 190 -- We are entering in a protected action, so we increase the protected 191 -- object nesting level (if pragma Detect_Blocking is active). 192 193 if Detect_Blocking then 194 declare 195 Self_Id : constant Task_Id := Self; 196 begin 197 -- Update the protected object's owner 198 199 Object.Owner := Self_Id; 200 201 -- Increase protected object nesting level 202 203 Self_Id.Common.Protected_Action_Nesting := 204 Self_Id.Common.Protected_Action_Nesting + 1; 205 end; 206 end if; 207 end Lock_Read_Only; 208 209 ----------------- 210 -- Set_Ceiling -- 211 ----------------- 212 213 procedure Set_Ceiling 214 (Object : Protection_Access; 215 Prio : System.Any_Priority) is 216 begin 217 Object.New_Ceiling := Prio; 218 end Set_Ceiling; 219 220 ------------ 221 -- Unlock -- 222 ------------ 223 224 procedure Unlock (Object : Protection_Access) is 225 begin 226 -- We are exiting from a protected action, so that we decrease the 227 -- protected object nesting level (if pragma Detect_Blocking is 228 -- active), and remove ownership of the protected object. 229 230 if Detect_Blocking then 231 declare 232 Self_Id : constant Task_Id := Self; 233 234 begin 235 -- Calls to this procedure can only take place when being within 236 -- a protected action and when the caller is the protected 237 -- object's owner. 238 239 pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0 240 and then Object.Owner = Self_Id); 241 242 -- Remove ownership of the protected object 243 244 Object.Owner := Null_Task; 245 246 -- We are exiting from a protected action, so we decrease the 247 -- protected object nesting level. 248 249 Self_Id.Common.Protected_Action_Nesting := 250 Self_Id.Common.Protected_Action_Nesting - 1; 251 end; 252 end if; 253 254 -- Before releasing the mutex we must actually update its ceiling 255 -- priority if it has been changed. 256 257 if Object.New_Ceiling /= Object.Ceiling then 258 if Locking_Policy = 'C' then 259 System.Task_Primitives.Operations.Set_Ceiling 260 (Object.L'Access, Object.New_Ceiling); 261 end if; 262 263 Object.Ceiling := Object.New_Ceiling; 264 end if; 265 266 Unlock (Object.L'Access); 267 268 if Parameters.Runtime_Traces then 269 Send_Trace_Info (PO_Unlock); 270 end if; 271 end Unlock; 272 273begin 274 -- Ensure that tasking is initialized, as well as tasking soft links 275 -- when using protected objects. 276 277 Tasking.Initialize; 278 System.Soft_Links.Tasking.Init_Tasking_Soft_Links; 279end System.Tasking.Protected_Objects; 280