1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1998-2013, 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 32pragma Style_Checks (All_Checks); 33-- Turn off subprogram ordering check, since restricted GNARLI subprograms are 34-- gathered together at end. 35 36-- This package provides an optimized version of Protected_Objects.Operations 37-- and Protected_Objects.Entries making the following assumptions: 38 39-- PO has only one entry 40-- There is only one caller at a time (No_Entry_Queue) 41-- There is no dynamic priority support (No_Dynamic_Priorities) 42-- No Abort Statements 43-- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0) 44-- PO are at library level 45-- No Requeue 46-- None of the tasks will terminate (no need for finalization) 47 48-- This interface is intended to be used in the ravenscar and restricted 49-- profiles, the compiler is responsible for ensuring that the conditions 50-- mentioned above are respected, except for the No_Entry_Queue restriction 51-- that is checked dynamically in this package, since the check cannot be 52-- performed at compile time, and is relatively cheap (see PO_Do_Or_Queue, 53-- Service_Entry). 54 55pragma Polling (Off); 56-- Turn off polling, we do not want polling to take place during tasking 57-- operations. It can cause infinite loops and other problems. 58 59pragma Suppress (All_Checks); 60-- Why is this required ??? 61 62with Ada.Exceptions; 63 64with System.Task_Primitives.Operations; 65with System.Parameters; 66 67package body System.Tasking.Protected_Objects.Single_Entry is 68 69 package STPO renames System.Task_Primitives.Operations; 70 71 use Parameters; 72 73 ----------------------- 74 -- Local Subprograms -- 75 ----------------------- 76 77 procedure Send_Program_Error (Entry_Call : Entry_Call_Link); 78 pragma Inline (Send_Program_Error); 79 -- Raise Program_Error in the caller of the specified entry call 80 81 -------------------------- 82 -- Entry Calls Handling -- 83 -------------------------- 84 85 procedure Wakeup_Entry_Caller (Entry_Call : Entry_Call_Link); 86 pragma Inline (Wakeup_Entry_Caller); 87 -- This is called at the end of service of an entry call, to abort the 88 -- caller if he is in an abortable part, and to wake up the caller if he 89 -- is on Entry_Caller_Sleep. Call it holding the lock of Entry_Call.Self. 90 91 procedure Wait_For_Completion (Entry_Call : Entry_Call_Link); 92 pragma Inline (Wait_For_Completion); 93 -- This procedure suspends the calling task until the specified entry call 94 -- has either been completed or cancelled. On exit, the call will not be 95 -- queued. This waits for calls on protected entries. 96 -- Call this only when holding Self_ID locked. 97 98 procedure Check_Exception 99 (Self_ID : Task_Id; 100 Entry_Call : Entry_Call_Link); 101 pragma Inline (Check_Exception); 102 -- Raise any pending exception from the Entry_Call. This should be called 103 -- at the end of every compiler interface procedure that implements an 104 -- entry call. The caller should not be holding any locks, or there will 105 -- be deadlock. 106 107 procedure PO_Do_Or_Queue 108 (Object : Protection_Entry_Access; 109 Entry_Call : Entry_Call_Link); 110 -- This procedure executes or queues an entry call, depending on the status 111 -- of the corresponding barrier. The specified object is assumed locked. 112 113 --------------------- 114 -- Check_Exception -- 115 --------------------- 116 117 procedure Check_Exception 118 (Self_ID : Task_Id; 119 Entry_Call : Entry_Call_Link) 120 is 121 pragma Warnings (Off, Self_ID); 122 123 procedure Internal_Raise (X : Ada.Exceptions.Exception_Id); 124 pragma Import (C, Internal_Raise, "__gnat_raise_with_msg"); 125 126 use type Ada.Exceptions.Exception_Id; 127 128 E : constant Ada.Exceptions.Exception_Id := 129 Entry_Call.Exception_To_Raise; 130 131 begin 132 if E /= Ada.Exceptions.Null_Id then 133 Internal_Raise (E); 134 end if; 135 end Check_Exception; 136 137 ------------------------ 138 -- Send_Program_Error -- 139 ------------------------ 140 141 procedure Send_Program_Error (Entry_Call : Entry_Call_Link) is 142 Caller : constant Task_Id := Entry_Call.Self; 143 144 begin 145 Entry_Call.Exception_To_Raise := Program_Error'Identity; 146 147 if Single_Lock then 148 STPO.Lock_RTS; 149 end if; 150 151 STPO.Write_Lock (Caller); 152 Wakeup_Entry_Caller (Entry_Call); 153 STPO.Unlock (Caller); 154 155 if Single_Lock then 156 STPO.Unlock_RTS; 157 end if; 158 end Send_Program_Error; 159 160 ------------------------- 161 -- Wait_For_Completion -- 162 ------------------------- 163 164 procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is 165 Self_Id : constant Task_Id := Entry_Call.Self; 166 begin 167 Self_Id.Common.State := Entry_Caller_Sleep; 168 STPO.Sleep (Self_Id, Entry_Caller_Sleep); 169 Self_Id.Common.State := Runnable; 170 end Wait_For_Completion; 171 172 ------------------------- 173 -- Wakeup_Entry_Caller -- 174 ------------------------- 175 176 -- This is called at the end of service of an entry call, to abort the 177 -- caller if he is in an abortable part, and to wake up the caller if it 178 -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue. 179 180 -- (This enforces the rule that a task must be off-queue if its state is 181 -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self. 182 183 -- The caller is waiting on Entry_Caller_Sleep, in Wait_For_Completion. 184 185 procedure Wakeup_Entry_Caller 186 (Entry_Call : Entry_Call_Link) 187 is 188 Caller : constant Task_Id := Entry_Call.Self; 189 begin 190 pragma Assert 191 (Caller.Common.State /= Terminated and then 192 Caller.Common.State /= Unactivated); 193 Entry_Call.State := Done; 194 STPO.Wakeup (Caller, Entry_Caller_Sleep); 195 end Wakeup_Entry_Caller; 196 197 ----------------------- 198 -- Restricted GNARLI -- 199 ----------------------- 200 201 -------------------------------------------- 202 -- Exceptional_Complete_Single_Entry_Body -- 203 -------------------------------------------- 204 205 procedure Exceptional_Complete_Single_Entry_Body 206 (Object : Protection_Entry_Access; 207 Ex : Ada.Exceptions.Exception_Id) 208 is 209 begin 210 Object.Call_In_Progress.Exception_To_Raise := Ex; 211 end Exceptional_Complete_Single_Entry_Body; 212 213 --------------------------------- 214 -- Initialize_Protection_Entry -- 215 --------------------------------- 216 217 procedure Initialize_Protection_Entry 218 (Object : Protection_Entry_Access; 219 Ceiling_Priority : Integer; 220 Compiler_Info : System.Address; 221 Entry_Body : Entry_Body_Access) 222 is 223 begin 224 Initialize_Protection (Object.Common'Access, Ceiling_Priority); 225 226 Object.Compiler_Info := Compiler_Info; 227 Object.Call_In_Progress := null; 228 Object.Entry_Body := Entry_Body; 229 Object.Entry_Queue := null; 230 end Initialize_Protection_Entry; 231 232 ---------------- 233 -- Lock_Entry -- 234 ---------------- 235 236 -- Compiler interface only 237 238 -- Do not call this procedure from within the run-time system. 239 240 procedure Lock_Entry (Object : Protection_Entry_Access) is 241 begin 242 Lock (Object.Common'Access); 243 end Lock_Entry; 244 245 -------------------------- 246 -- Lock_Read_Only_Entry -- 247 -------------------------- 248 249 -- Compiler interface only 250 251 -- Do not call this procedure from within the runtime system 252 253 procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is 254 begin 255 Lock_Read_Only (Object.Common'Access); 256 end Lock_Read_Only_Entry; 257 258 -------------------- 259 -- PO_Do_Or_Queue -- 260 -------------------- 261 262 procedure PO_Do_Or_Queue 263 (Object : Protection_Entry_Access; 264 Entry_Call : Entry_Call_Link) 265 is 266 Barrier_Value : Boolean; 267 268 begin 269 -- When the Action procedure for an entry body returns, it must be 270 -- completed (having called [Exceptional_]Complete_Entry_Body). 271 272 Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1); 273 274 if Barrier_Value then 275 if Object.Call_In_Progress /= null then 276 277 -- This violates the No_Entry_Queue restriction, send 278 -- Program_Error to the caller. 279 280 Send_Program_Error (Entry_Call); 281 return; 282 end if; 283 284 Object.Call_In_Progress := Entry_Call; 285 Object.Entry_Body.Action 286 (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1); 287 Object.Call_In_Progress := null; 288 289 if Single_Lock then 290 STPO.Lock_RTS; 291 end if; 292 293 STPO.Write_Lock (Entry_Call.Self); 294 Wakeup_Entry_Caller (Entry_Call); 295 STPO.Unlock (Entry_Call.Self); 296 297 if Single_Lock then 298 STPO.Unlock_RTS; 299 end if; 300 301 else 302 pragma Assert (Entry_Call.Mode = Simple_Call); 303 304 if Object.Entry_Queue /= null then 305 306 -- This violates the No_Entry_Queue restriction, send 307 -- Program_Error to the caller. 308 309 Send_Program_Error (Entry_Call); 310 return; 311 else 312 Object.Entry_Queue := Entry_Call; 313 end if; 314 315 end if; 316 317 exception 318 when others => 319 Send_Program_Error (Entry_Call); 320 end PO_Do_Or_Queue; 321 322 ---------------------------- 323 -- Protected_Single_Count -- 324 ---------------------------- 325 326 function Protected_Count_Entry (Object : Protection_Entry) return Natural is 327 begin 328 if Object.Entry_Queue /= null then 329 return 1; 330 else 331 return 0; 332 end if; 333 end Protected_Count_Entry; 334 335 --------------------------------- 336 -- Protected_Single_Entry_Call -- 337 --------------------------------- 338 339 procedure Protected_Single_Entry_Call 340 (Object : Protection_Entry_Access; 341 Uninterpreted_Data : System.Address) 342 is 343 Self_Id : constant Task_Id := STPO.Self; 344 Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1); 345 begin 346 -- If pragma Detect_Blocking is active then Program_Error must be 347 -- raised if this potentially blocking operation is called from a 348 -- protected action. 349 350 if Detect_Blocking 351 and then Self_Id.Common.Protected_Action_Nesting > 0 352 then 353 raise Program_Error with "potentially blocking operation"; 354 end if; 355 356 Lock_Entry (Object); 357 358 Entry_Call.Mode := Simple_Call; 359 Entry_Call.State := Now_Abortable; 360 Entry_Call.Uninterpreted_Data := Uninterpreted_Data; 361 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; 362 363 PO_Do_Or_Queue (Object, Entry_Call'Access); 364 Unlock_Entry (Object); 365 366 -- The call is either `Done' or not. It cannot be cancelled since there 367 -- is no ATC construct. 368 369 pragma Assert (Entry_Call.State /= Cancelled); 370 371 if Entry_Call.State /= Done then 372 if Single_Lock then 373 STPO.Lock_RTS; 374 end if; 375 376 STPO.Write_Lock (Self_Id); 377 Wait_For_Completion (Entry_Call'Access); 378 STPO.Unlock (Self_Id); 379 380 if Single_Lock then 381 STPO.Unlock_RTS; 382 end if; 383 end if; 384 385 Check_Exception (Self_Id, Entry_Call'Access); 386 end Protected_Single_Entry_Call; 387 388 ----------------------------------- 389 -- Protected_Single_Entry_Caller -- 390 ----------------------------------- 391 392 function Protected_Single_Entry_Caller 393 (Object : Protection_Entry) return Task_Id 394 is 395 begin 396 return Object.Call_In_Progress.Self; 397 end Protected_Single_Entry_Caller; 398 399 ------------------- 400 -- Service_Entry -- 401 ------------------- 402 403 procedure Service_Entry (Object : Protection_Entry_Access) is 404 Entry_Call : constant Entry_Call_Link := Object.Entry_Queue; 405 Caller : Task_Id; 406 407 begin 408 if Entry_Call /= null 409 and then Object.Entry_Body.Barrier (Object.Compiler_Info, 1) 410 then 411 Object.Entry_Queue := null; 412 413 if Object.Call_In_Progress /= null then 414 415 -- Violation of No_Entry_Queue restriction, raise exception 416 417 Send_Program_Error (Entry_Call); 418 Unlock_Entry (Object); 419 return; 420 end if; 421 422 Object.Call_In_Progress := Entry_Call; 423 Object.Entry_Body.Action 424 (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1); 425 Object.Call_In_Progress := null; 426 Caller := Entry_Call.Self; 427 Unlock_Entry (Object); 428 429 if Single_Lock then 430 STPO.Lock_RTS; 431 end if; 432 433 STPO.Write_Lock (Caller); 434 Wakeup_Entry_Caller (Entry_Call); 435 STPO.Unlock (Caller); 436 437 if Single_Lock then 438 STPO.Unlock_RTS; 439 end if; 440 441 else 442 -- Just unlock the entry 443 444 Unlock_Entry (Object); 445 end if; 446 447 exception 448 when others => 449 Send_Program_Error (Entry_Call); 450 Unlock_Entry (Object); 451 end Service_Entry; 452 453 ------------------ 454 -- Unlock_Entry -- 455 ------------------ 456 457 procedure Unlock_Entry (Object : Protection_Entry_Access) is 458 begin 459 Unlock (Object.Common'Access); 460 end Unlock_Entry; 461 462end System.Tasking.Protected_Objects.Single_Entry; 463