1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1998-2019, 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 32-- This package contains all the simple primitives related to protected 33-- objects with entries (i.e init, lock, unlock). 34 35-- The handling of protected objects with no entries is done in 36-- System.Tasking.Protected_Objects, the complex routines for protected 37-- objects with entries in System.Tasking.Protected_Objects.Operations. 38 39-- The split between Entries and Operations is needed to break circular 40-- dependencies inside the run time. 41 42-- Note: the compiler generates direct calls to this interface, via Rtsfind 43 44with System.Task_Primitives.Operations; 45with System.Restrictions; 46with System.Parameters; 47 48with System.Tasking.Initialization; 49pragma Elaborate_All (System.Tasking.Initialization); 50-- To insure that tasking is initialized if any protected objects are created 51 52package body System.Tasking.Protected_Objects.Entries is 53 54 package STPO renames System.Task_Primitives.Operations; 55 56 use Parameters; 57 use Task_Primitives.Operations; 58 59 ---------------- 60 -- Local Data -- 61 ---------------- 62 63 Locking_Policy : Character; 64 pragma Import (C, Locking_Policy, "__gl_locking_policy"); 65 66 -------------- 67 -- Finalize -- 68 -------------- 69 70 overriding procedure Finalize (Object : in out Protection_Entries) is 71 Entry_Call : Entry_Call_Link; 72 Caller : Task_Id; 73 Ceiling_Violation : Boolean; 74 Self_ID : constant Task_Id := STPO.Self; 75 Old_Base_Priority : System.Any_Priority; 76 77 begin 78 if Object.Finalized then 79 return; 80 end if; 81 82 STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation); 83 84 if Single_Lock then 85 Lock_RTS; 86 end if; 87 88 if Ceiling_Violation then 89 90 -- Dip our own priority down to ceiling of lock. See similar code in 91 -- Tasking.Entry_Calls.Lock_Server. 92 93 STPO.Write_Lock (Self_ID); 94 Old_Base_Priority := Self_ID.Common.Base_Priority; 95 Self_ID.New_Base_Priority := Object.Ceiling; 96 Initialization.Change_Base_Priority (Self_ID); 97 STPO.Unlock (Self_ID); 98 99 if Single_Lock then 100 Unlock_RTS; 101 end if; 102 103 STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation); 104 105 if Ceiling_Violation then 106 raise Program_Error with "ceiling violation"; 107 end if; 108 109 if Single_Lock then 110 Lock_RTS; 111 end if; 112 113 Object.Old_Base_Priority := Old_Base_Priority; 114 Object.Pending_Action := True; 115 end if; 116 117 -- Send program_error to all tasks still queued on this object 118 119 for E in Object.Entry_Queues'Range loop 120 Entry_Call := Object.Entry_Queues (E).Head; 121 122 while Entry_Call /= null loop 123 Caller := Entry_Call.Self; 124 Entry_Call.Exception_To_Raise := Program_Error'Identity; 125 126 STPO.Write_Lock (Caller); 127 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); 128 STPO.Unlock (Caller); 129 130 exit when Entry_Call = Object.Entry_Queues (E).Tail; 131 Entry_Call := Entry_Call.Next; 132 end loop; 133 end loop; 134 135 Object.Finalized := True; 136 137 if Single_Lock then 138 Unlock_RTS; 139 end if; 140 141 STPO.Unlock (Object.L'Unrestricted_Access); 142 143 STPO.Finalize_Lock (Object.L'Unrestricted_Access); 144 end Finalize; 145 146 ----------------- 147 -- Get_Ceiling -- 148 ----------------- 149 150 function Get_Ceiling 151 (Object : Protection_Entries_Access) return System.Any_Priority is 152 begin 153 return Object.New_Ceiling; 154 end Get_Ceiling; 155 156 ------------------------------------- 157 -- Has_Interrupt_Or_Attach_Handler -- 158 ------------------------------------- 159 160 function Has_Interrupt_Or_Attach_Handler 161 (Object : Protection_Entries_Access) 162 return Boolean 163 is 164 pragma Warnings (Off, Object); 165 begin 166 return False; 167 end Has_Interrupt_Or_Attach_Handler; 168 169 ----------------------------------- 170 -- Initialize_Protection_Entries -- 171 ----------------------------------- 172 173 procedure Initialize_Protection_Entries 174 (Object : Protection_Entries_Access; 175 Ceiling_Priority : Integer; 176 Compiler_Info : System.Address; 177 Entry_Queue_Maxes : Protected_Entry_Queue_Max_Access; 178 Entry_Bodies : Protected_Entry_Body_Access; 179 Find_Body_Index : Find_Body_Index_Access) 180 is 181 Init_Priority : Integer := Ceiling_Priority; 182 Self_ID : constant Task_Id := STPO.Self; 183 184 begin 185 if Init_Priority = Unspecified_Priority then 186 Init_Priority := System.Priority'Last; 187 end if; 188 189 if Locking_Policy = 'C' 190 and then Has_Interrupt_Or_Attach_Handler (Object) 191 and then Init_Priority not in System.Interrupt_Priority 192 then 193 -- Required by C.3.1(11) 194 195 raise Program_Error; 196 end if; 197 198 -- If a PO is created from a controlled operation, abort is already 199 -- deferred at this point, so we need to use Defer_Abort_Nestable. In 200 -- some cases, the following assertion can help to spot inconsistencies, 201 -- outside the above scenario involving controlled types. 202 203 -- pragma Assert (Self_Id.Deferral_Level = 0); 204 205 Initialization.Defer_Abort_Nestable (Self_ID); 206 Initialize_Lock (Init_Priority, Object.L'Access); 207 Initialization.Undefer_Abort_Nestable (Self_ID); 208 209 Object.Ceiling := System.Any_Priority (Init_Priority); 210 Object.New_Ceiling := System.Any_Priority (Init_Priority); 211 Object.Owner := Null_Task; 212 Object.Compiler_Info := Compiler_Info; 213 Object.Pending_Action := False; 214 Object.Call_In_Progress := null; 215 Object.Entry_Queue_Maxes := Entry_Queue_Maxes; 216 Object.Entry_Bodies := Entry_Bodies; 217 Object.Find_Body_Index := Find_Body_Index; 218 219 for E in Object.Entry_Queues'Range loop 220 Object.Entry_Queues (E).Head := null; 221 Object.Entry_Queues (E).Tail := null; 222 end loop; 223 end Initialize_Protection_Entries; 224 225 ------------------ 226 -- Lock_Entries -- 227 ------------------ 228 229 procedure Lock_Entries (Object : Protection_Entries_Access) is 230 Ceiling_Violation : Boolean; 231 232 begin 233 Lock_Entries_With_Status (Object, Ceiling_Violation); 234 235 if Ceiling_Violation then 236 raise Program_Error with "ceiling violation"; 237 end if; 238 end Lock_Entries; 239 240 ------------------------------ 241 -- Lock_Entries_With_Status -- 242 ------------------------------ 243 244 procedure Lock_Entries_With_Status 245 (Object : Protection_Entries_Access; 246 Ceiling_Violation : out Boolean) 247 is 248 begin 249 if Object.Finalized then 250 raise Program_Error with "protected object is finalized"; 251 end if; 252 253 -- If pragma Detect_Blocking is active then, as described in the ARM 254 -- 9.5.1, par. 15, we must check whether this is an external call on a 255 -- protected subprogram with the same target object as that of the 256 -- protected action that is currently in progress (i.e., if the caller 257 -- is already the protected object's owner). If this is the case hence 258 -- Program_Error must be raised. 259 260 if Detect_Blocking and then Object.Owner = Self then 261 raise Program_Error; 262 end if; 263 264 -- The lock is made without deferring abort 265 266 -- Therefore the abort has to be deferred before calling this routine. 267 -- This means that the compiler has to generate a Defer_Abort call 268 -- before the call to Lock. 269 270 -- The caller is responsible for undeferring abort, and compiler 271 -- generated calls must be protected with cleanup handlers to ensure 272 -- that abort is undeferred in all cases. 273 274 pragma Assert 275 (STPO.Self.Deferral_Level > 0 276 or else not Restrictions.Abort_Allowed); 277 278 Write_Lock (Object.L'Access, Ceiling_Violation); 279 280 -- We are entering in a protected action, so that we increase the 281 -- protected object nesting level (if pragma Detect_Blocking is 282 -- active), and update the protected object's owner. 283 284 if Detect_Blocking then 285 declare 286 Self_Id : constant Task_Id := Self; 287 288 begin 289 -- Update the protected object's owner 290 291 Object.Owner := Self_Id; 292 293 -- Increase protected object nesting level 294 295 Self_Id.Common.Protected_Action_Nesting := 296 Self_Id.Common.Protected_Action_Nesting + 1; 297 end; 298 end if; 299 end Lock_Entries_With_Status; 300 301 ---------------------------- 302 -- Lock_Read_Only_Entries -- 303 ---------------------------- 304 305 procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is 306 Ceiling_Violation : Boolean; 307 308 begin 309 if Object.Finalized then 310 raise Program_Error with "protected object is finalized"; 311 end if; 312 313 -- If pragma Detect_Blocking is active then, as described in the ARM 314 -- 9.5.1, par. 15, we must check whether this is an external call on a 315 -- protected subprogram with the same target object as that of the 316 -- protected action that is currently in progress (i.e., if the caller 317 -- is already the protected object's owner). If this is the case hence 318 -- Program_Error must be raised. 319 320 -- Note that in this case (getting read access), several tasks may 321 -- have read ownership of the protected object, so that this method of 322 -- storing the (single) protected object's owner does not work 323 -- reliably for read locks. However, this is the approach taken for two 324 -- major reasons: first, this function is not currently being used (it 325 -- is provided for possible future use), and second, it largely 326 -- simplifies the implementation. 327 328 if Detect_Blocking and then Object.Owner = Self then 329 raise Program_Error; 330 end if; 331 332 Read_Lock (Object.L'Access, Ceiling_Violation); 333 334 if Ceiling_Violation then 335 raise Program_Error with "ceiling violation"; 336 end if; 337 338 -- We are entering in a protected action, so that we increase the 339 -- protected object nesting level (if pragma Detect_Blocking is 340 -- active), and update the protected object's owner. 341 342 if Detect_Blocking then 343 declare 344 Self_Id : constant Task_Id := Self; 345 346 begin 347 -- Update the protected object's owner 348 349 Object.Owner := Self_Id; 350 351 -- Increase protected object nesting level 352 353 Self_Id.Common.Protected_Action_Nesting := 354 Self_Id.Common.Protected_Action_Nesting + 1; 355 end; 356 end if; 357 end Lock_Read_Only_Entries; 358 359 ----------------------- 360 -- Number_Of_Entries -- 361 ----------------------- 362 363 function Number_Of_Entries 364 (Object : Protection_Entries_Access) return Entry_Index 365 is 366 begin 367 return Entry_Index (Object.Num_Entries); 368 end Number_Of_Entries; 369 370 ----------------- 371 -- Set_Ceiling -- 372 ----------------- 373 374 procedure Set_Ceiling 375 (Object : Protection_Entries_Access; 376 Prio : System.Any_Priority) is 377 begin 378 Object.New_Ceiling := Prio; 379 end Set_Ceiling; 380 381 -------------------- 382 -- Unlock_Entries -- 383 -------------------- 384 385 procedure Unlock_Entries (Object : Protection_Entries_Access) is 386 begin 387 -- We are exiting from a protected action, so that we decrease the 388 -- protected object nesting level (if pragma Detect_Blocking is 389 -- active), and remove ownership of the protected object. 390 391 if Detect_Blocking then 392 declare 393 Self_Id : constant Task_Id := Self; 394 395 begin 396 -- Calls to this procedure can only take place when being within 397 -- a protected action and when the caller is the protected 398 -- object's owner. 399 400 pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0 401 and then Object.Owner = Self_Id); 402 403 -- Remove ownership of the protected object 404 405 Object.Owner := Null_Task; 406 407 Self_Id.Common.Protected_Action_Nesting := 408 Self_Id.Common.Protected_Action_Nesting - 1; 409 end; 410 end if; 411 412 -- Before releasing the mutex we must actually update its ceiling 413 -- priority if it has been changed. 414 415 if Object.New_Ceiling /= Object.Ceiling then 416 if Locking_Policy = 'C' then 417 System.Task_Primitives.Operations.Set_Ceiling 418 (Object.L'Access, Object.New_Ceiling); 419 end if; 420 421 Object.Ceiling := Object.New_Ceiling; 422 end if; 423 424 Unlock (Object.L'Access); 425 end Unlock_Entries; 426 427end System.Tasking.Protected_Objects.Entries; 428