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-2014, 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_Bodies : Protected_Entry_Body_Access; 178 Find_Body_Index : Find_Body_Index_Access) 179 is 180 Init_Priority : Integer := Ceiling_Priority; 181 Self_ID : constant Task_Id := STPO.Self; 182 183 begin 184 if Init_Priority = Unspecified_Priority then 185 Init_Priority := System.Priority'Last; 186 end if; 187 188 if Locking_Policy = 'C' 189 and then Has_Interrupt_Or_Attach_Handler (Object) 190 and then Init_Priority not in System.Interrupt_Priority 191 then 192 -- Required by C.3.1(11) 193 194 raise Program_Error; 195 end if; 196 197 -- If a PO is created from a controlled operation, abort is already 198 -- deferred at this point, so we need to use Defer_Abort_Nestable. In 199 -- some cases, the following assertion can help to spot inconsistencies, 200 -- outside the above scenario involving controlled types. 201 202 -- pragma Assert (Self_Id.Deferral_Level = 0); 203 204 Initialization.Defer_Abort_Nestable (Self_ID); 205 Initialize_Lock (Init_Priority, Object.L'Access); 206 Initialization.Undefer_Abort_Nestable (Self_ID); 207 208 Object.Ceiling := System.Any_Priority (Init_Priority); 209 Object.New_Ceiling := System.Any_Priority (Init_Priority); 210 Object.Owner := Null_Task; 211 Object.Compiler_Info := Compiler_Info; 212 Object.Pending_Action := False; 213 Object.Call_In_Progress := null; 214 Object.Entry_Bodies := Entry_Bodies; 215 Object.Find_Body_Index := Find_Body_Index; 216 217 for E in Object.Entry_Queues'Range loop 218 Object.Entry_Queues (E).Head := null; 219 Object.Entry_Queues (E).Tail := null; 220 end loop; 221 end Initialize_Protection_Entries; 222 223 ------------------ 224 -- Lock_Entries -- 225 ------------------ 226 227 procedure Lock_Entries (Object : Protection_Entries_Access) is 228 Ceiling_Violation : Boolean; 229 230 begin 231 Lock_Entries_With_Status (Object, Ceiling_Violation); 232 233 if Ceiling_Violation then 234 raise Program_Error with "ceiling violation"; 235 end if; 236 end Lock_Entries; 237 238 ------------------------------ 239 -- Lock_Entries_With_Status -- 240 ------------------------------ 241 242 procedure Lock_Entries_With_Status 243 (Object : Protection_Entries_Access; 244 Ceiling_Violation : out Boolean) 245 is 246 begin 247 if Object.Finalized then 248 raise Program_Error with "protected object is finalized"; 249 end if; 250 251 -- If pragma Detect_Blocking is active then, as described in the ARM 252 -- 9.5.1, par. 15, we must check whether this is an external call on a 253 -- protected subprogram with the same target object as that of the 254 -- protected action that is currently in progress (i.e., if the caller 255 -- is already the protected object's owner). If this is the case hence 256 -- Program_Error must be raised. 257 258 if Detect_Blocking and then Object.Owner = Self then 259 raise Program_Error; 260 end if; 261 262 -- The lock is made without deferring abort 263 264 -- Therefore the abort has to be deferred before calling this routine. 265 -- This means that the compiler has to generate a Defer_Abort call 266 -- before the call to Lock. 267 268 -- The caller is responsible for undeferring abort, and compiler 269 -- generated calls must be protected with cleanup handlers to ensure 270 -- that abort is undeferred in all cases. 271 272 pragma Assert 273 (STPO.Self.Deferral_Level > 0 274 or else not Restrictions.Abort_Allowed); 275 276 Write_Lock (Object.L'Access, Ceiling_Violation); 277 278 -- We are entering in a protected action, so that we increase the 279 -- protected object nesting level (if pragma Detect_Blocking is 280 -- active), and update the protected object's owner. 281 282 if Detect_Blocking then 283 declare 284 Self_Id : constant Task_Id := Self; 285 286 begin 287 -- Update the protected object's owner 288 289 Object.Owner := Self_Id; 290 291 -- Increase protected object nesting level 292 293 Self_Id.Common.Protected_Action_Nesting := 294 Self_Id.Common.Protected_Action_Nesting + 1; 295 end; 296 end if; 297 end Lock_Entries_With_Status; 298 299 ---------------------------- 300 -- Lock_Read_Only_Entries -- 301 ---------------------------- 302 303 procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is 304 Ceiling_Violation : Boolean; 305 306 begin 307 if Object.Finalized then 308 raise Program_Error with "protected object is finalized"; 309 end if; 310 311 -- If pragma Detect_Blocking is active then, as described in the ARM 312 -- 9.5.1, par. 15, we must check whether this is an external call on a 313 -- protected subprogram with the same target object as that of the 314 -- protected action that is currently in progress (i.e., if the caller 315 -- is already the protected object's owner). If this is the case hence 316 -- Program_Error must be raised. 317 318 -- Note that in this case (getting read access), several tasks may 319 -- have read ownership of the protected object, so that this method of 320 -- storing the (single) protected object's owner does not work 321 -- reliably for read locks. However, this is the approach taken for two 322 -- major reasons: first, this function is not currently being used (it 323 -- is provided for possible future use), and second, it largely 324 -- simplifies the implementation. 325 326 if Detect_Blocking and then Object.Owner = Self then 327 raise Program_Error; 328 end if; 329 330 Read_Lock (Object.L'Access, Ceiling_Violation); 331 332 if Ceiling_Violation then 333 raise Program_Error with "ceiling violation"; 334 end if; 335 336 -- We are entering in a protected action, so that we increase the 337 -- protected object nesting level (if pragma Detect_Blocking is 338 -- active), and update the protected object's owner. 339 340 if Detect_Blocking then 341 declare 342 Self_Id : constant Task_Id := Self; 343 344 begin 345 -- Update the protected object's owner 346 347 Object.Owner := Self_Id; 348 349 -- Increase protected object nesting level 350 351 Self_Id.Common.Protected_Action_Nesting := 352 Self_Id.Common.Protected_Action_Nesting + 1; 353 end; 354 end if; 355 end Lock_Read_Only_Entries; 356 357 ----------------------- 358 -- Number_Of_Entries -- 359 ----------------------- 360 361 function Number_Of_Entries 362 (Object : Protection_Entries_Access) return Entry_Index 363 is 364 begin 365 return Entry_Index (Object.Num_Entries); 366 end Number_Of_Entries; 367 368 ----------------- 369 -- Set_Ceiling -- 370 ----------------- 371 372 procedure Set_Ceiling 373 (Object : Protection_Entries_Access; 374 Prio : System.Any_Priority) is 375 begin 376 Object.New_Ceiling := Prio; 377 end Set_Ceiling; 378 379 --------------------- 380 -- Set_Entry_Names -- 381 --------------------- 382 383 procedure Set_Entry_Names 384 (Object : Protection_Entries_Access; 385 Names : Protected_Entry_Names_Access) 386 is 387 begin 388 Object.Entry_Names := Names; 389 end Set_Entry_Names; 390 391 -------------------- 392 -- Unlock_Entries -- 393 -------------------- 394 395 procedure Unlock_Entries (Object : Protection_Entries_Access) is 396 begin 397 -- We are exiting from a protected action, so that we decrease the 398 -- protected object nesting level (if pragma Detect_Blocking is 399 -- active), and remove ownership of the protected object. 400 401 if Detect_Blocking then 402 declare 403 Self_Id : constant Task_Id := Self; 404 405 begin 406 -- Calls to this procedure can only take place when being within 407 -- a protected action and when the caller is the protected 408 -- object's owner. 409 410 pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0 411 and then Object.Owner = Self_Id); 412 413 -- Remove ownership of the protected object 414 415 Object.Owner := Null_Task; 416 417 Self_Id.Common.Protected_Action_Nesting := 418 Self_Id.Common.Protected_Action_Nesting - 1; 419 end; 420 end if; 421 422 -- Before releasing the mutex we must actually update its ceiling 423 -- priority if it has been changed. 424 425 if Object.New_Ceiling /= Object.Ceiling then 426 if Locking_Policy = 'C' then 427 System.Task_Primitives.Operations.Set_Ceiling 428 (Object.L'Access, Object.New_Ceiling); 429 end if; 430 431 Object.Ceiling := Object.New_Ceiling; 432 end if; 433 434 Unlock (Object.L'Access); 435 end Unlock_Entries; 436 437end System.Tasking.Protected_Objects.Entries; 438