1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- S Y S T E M . A S T _ H A N D L I N G -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1996-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT 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-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32-- This is the OpenVMS/IA64 version 33 34with System; use System; 35 36with System.IO; 37 38with System.Machine_Code; 39with System.Parameters; 40 41with System.Tasking; 42with System.Tasking.Rendezvous; 43with System.Tasking.Initialization; 44with System.Tasking.Utilities; 45 46with System.Task_Primitives; 47with System.Task_Primitives.Operations; 48with System.Task_Primitives.Operations.DEC; 49 50with Ada.Finalization; 51with Ada.Task_Attributes; 52 53with Ada.Exceptions; use Ada.Exceptions; 54 55with Ada.Unchecked_Conversion; 56with Ada.Unchecked_Deallocation; 57 58package body System.AST_Handling is 59 60 package ATID renames Ada.Task_Identification; 61 62 package SP renames System.Parameters; 63 package ST renames System.Tasking; 64 package STR renames System.Tasking.Rendezvous; 65 package STI renames System.Tasking.Initialization; 66 package STU renames System.Tasking.Utilities; 67 68 package STPO renames System.Task_Primitives.Operations; 69 package STPOD renames System.Task_Primitives.Operations.DEC; 70 71 AST_Lock : aliased System.Task_Primitives.RTS_Lock; 72 -- This is a global lock; it is used to execute in mutual exclusion 73 -- from all other AST tasks. It is only used by Lock_AST and 74 -- Unlock_AST. 75 76 procedure Lock_AST (Self_ID : ST.Task_Id); 77 -- Locks out other AST tasks. Preceding a section of code by Lock_AST and 78 -- following it by Unlock_AST creates a critical region. 79 80 procedure Unlock_AST (Self_ID : ST.Task_Id); 81 -- Releases lock previously set by call to Lock_AST. 82 -- All nested locks must be released before other tasks competing for the 83 -- tasking lock are released. 84 85 -------------- 86 -- Lock_AST -- 87 -------------- 88 89 procedure Lock_AST (Self_ID : ST.Task_Id) is 90 begin 91 STI.Defer_Abort_Nestable (Self_ID); 92 STPO.Write_Lock (AST_Lock'Access, Global_Lock => True); 93 end Lock_AST; 94 95 ---------------- 96 -- Unlock_AST -- 97 ---------------- 98 99 procedure Unlock_AST (Self_ID : ST.Task_Id) is 100 begin 101 STPO.Unlock (AST_Lock'Access, Global_Lock => True); 102 STI.Undefer_Abort_Nestable (Self_ID); 103 end Unlock_AST; 104 105 --------------------------------- 106 -- AST_Handler Data Structures -- 107 --------------------------------- 108 109 -- As noted in the private part of the spec of System.Aux_DEC, the 110 -- AST_Handler type is simply a pointer to a procedure that takes 111 -- a single 64bit parameter. The following is a local copy 112 -- of that definition. 113 114 -- We need our own copy because we need to get our hands on this 115 -- and we cannot see the private part of System.Aux_DEC. We don't 116 -- want to be a child of Aux_Dec because of complications resulting 117 -- from the use of pragma Extend_System. We will use unchecked 118 -- conversions between the two versions of the declarations. 119 120 type AST_Handler is access procedure (Param : Long_Integer); 121 122 -- However, this declaration is somewhat misleading, since the values 123 -- referenced by AST_Handler values (all produced in this package by 124 -- calls to Create_AST_Handler) are highly stylized. 125 126 -- The first point is that in VMS/I64, procedure pointers do not in 127 -- fact point to code, but rather to a procedure descriptor. 128 -- So a value of type AST_Handler is in fact a pointer to one of 129 -- descriptors. 130 131 type Descriptor_Type is 132 record 133 Entry_Point : System.Address; 134 GP_Value : System.Address; 135 end record; 136 for Descriptor_Type'Alignment use Standard'Maximum_Alignment; 137 -- pragma Warnings (Off, Descriptor_Type); 138 -- Suppress harmless warnings about alignment. 139 -- Should explain why this warning is harmless ??? 140 141 type Descriptor_Ref is access all Descriptor_Type; 142 143 -- Normally, there is only one such descriptor for a given procedure, but 144 -- it works fine to make a copy of the single allocated descriptor, and 145 -- use the copy itself, and we take advantage of this in the design here. 146 -- The idea is that AST_Handler values will all point to a record with the 147 -- following structure: 148 149 -- Note: When we say it works fine, there is one delicate point, which 150 -- is that the code for the AST procedure itself requires the original 151 -- descriptor address. We handle this by saving the orignal descriptor 152 -- address in this structure and restoring in Process_AST. 153 154 type AST_Handler_Data is record 155 Descriptor : Descriptor_Type; 156 Original_Descriptor_Ref : Descriptor_Ref; 157 Taskid : ATID.Task_Id; 158 Entryno : Natural; 159 end record; 160 161 type AST_Handler_Data_Ref is access all AST_Handler_Data; 162 163 function To_AST_Handler is new Ada.Unchecked_Conversion 164 (AST_Handler_Data_Ref, System.Aux_DEC.AST_Handler); 165 166 -- Each time Create_AST_Handler is called, a new value of this record 167 -- type is created, containing a copy of the procedure descriptor for 168 -- the routine used to handle all AST's (Process_AST), and the Task_Id 169 -- and entry number parameters identifying the task entry involved. 170 171 -- The AST_Handler value returned is a pointer to this record. Since 172 -- the record starts with the procedure descriptor, it can be used 173 -- by the system in the normal way to call the procedure. But now 174 -- when the procedure gets control, it can determine the address of 175 -- the procedure descriptor used to call it (since the ABI specifies 176 -- that this is left sitting in register r27 on entry), and then use 177 -- that address to retrieve the Task_Id and entry number so that it 178 -- knows on which entry to queue the AST request. 179 180 -- The next issue is where are these records placed. Since we intend 181 -- to pass pointers to these records to asynchronous system service 182 -- routines, they have to be on the heap, which means we have to worry 183 -- about when to allocate them and deallocate them. 184 185 -- We solve this problem by introducing a task attribute that points to 186 -- a vector, indexed by the entry number, of AST_Handler_Data records 187 -- for a given task. The pointer itself is a controlled object allowing 188 -- us to write a finalization routine that frees the referenced vector. 189 190 -- An entry in this vector is either initialized (Entryno non-zero) and 191 -- can be used for any subsequent reference to the same entry, or it is 192 -- unused, marked by the Entryno value being zero. 193 194 type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data; 195 type AST_Handler_Vector_Ref is access all AST_Handler_Vector; 196 197 type AST_Vector_Ptr is new Ada.Finalization.Controlled with record 198 Vector : AST_Handler_Vector_Ref; 199 end record; 200 201 procedure Finalize (Obj : in out AST_Vector_Ptr); 202 -- Override Finalize so that the AST Vector gets freed. 203 204 procedure Finalize (Obj : in out AST_Vector_Ptr) is 205 procedure Free is new 206 Ada.Unchecked_Deallocation (AST_Handler_Vector, AST_Handler_Vector_Ref); 207 begin 208 if Obj.Vector /= null then 209 Free (Obj.Vector); 210 end if; 211 end Finalize; 212 213 AST_Vector_Init : AST_Vector_Ptr; 214 -- Initial value, treated as constant, Vector will be null 215 216 package AST_Attribute is new Ada.Task_Attributes 217 (Attribute => AST_Vector_Ptr, 218 Initial_Value => AST_Vector_Init); 219 220 use AST_Attribute; 221 222 ----------------------- 223 -- AST Service Queue -- 224 ----------------------- 225 226 -- The following global data structures are used to queue pending 227 -- AST requests. When an AST is signalled, the AST service routine 228 -- Process_AST is called, and it makes an entry in this structure. 229 230 type AST_Instance is record 231 Taskid : ATID.Task_Id; 232 Entryno : Natural; 233 Param : Long_Integer; 234 end record; 235 -- The Taskid and Entryno indicate the entry on which this AST is to 236 -- be queued, and Param is the parameter provided from the AST itself. 237 238 AST_Service_Queue_Size : constant := 256; 239 AST_Service_Queue_Limit : constant := 250; 240 type AST_Service_Queue_Index is mod AST_Service_Queue_Size; 241 -- Index used to refer to entries in the circular buffer which holds 242 -- active AST_Instance values. The upper bound reflects the maximum 243 -- number of AST instances that can be stored in the buffer. Since 244 -- these entries are immediately serviced by the high priority server 245 -- task that does the actual entry queuing, it is very unusual to have 246 -- any significant number of entries simulaneously queued. 247 248 AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance; 249 pragma Volatile_Components (AST_Service_Queue); 250 -- The circular buffer used to store active AST requests 251 252 AST_Service_Queue_Put : AST_Service_Queue_Index := 0; 253 AST_Service_Queue_Get : AST_Service_Queue_Index := 0; 254 pragma Atomic (AST_Service_Queue_Put); 255 pragma Atomic (AST_Service_Queue_Get); 256 -- These two variables point to the next slots in the AST_Service_Queue 257 -- to be used for putting a new entry in and taking an entry out. This 258 -- is a circular buffer, so these pointers wrap around. If the two values 259 -- are equal the buffer is currently empty. The pointers are atomic to 260 -- ensure proper synchronization between the single producer (namely the 261 -- Process_AST procedure), and the single consumer (the AST_Service_Task). 262 263 -------------------------------- 264 -- AST Server Task Structures -- 265 -------------------------------- 266 267 -- The basic approach is that when an AST comes in, a call is made to 268 -- the Process_AST procedure. It queues the request in the service queue 269 -- and then wakes up an AST server task to perform the actual call to the 270 -- required entry. We use this intermediate server task, since the AST 271 -- procedure itself cannot wait to return, and we need some caller for 272 -- the rendezvous so that we can use the normal rendezvous mechanism. 273 274 -- It would work to have only one AST server task, but then we would lose 275 -- all overlap in AST processing, and furthermore, we could get priority 276 -- inversion effects resulting in starvation of AST requests. 277 278 -- We therefore maintain a small pool of AST server tasks. We adjust 279 -- the size of the pool dynamically to reflect traffic, so that we have 280 -- a sufficient number of server tasks to avoid starvation. 281 282 Max_AST_Servers : constant Natural := 16; 283 -- Maximum number of AST server tasks that can be allocated 284 285 Num_AST_Servers : Natural := 0; 286 -- Number of AST server tasks currently active 287 288 Num_Waiting_AST_Servers : Natural := 0; 289 -- This is the number of AST server tasks that are either waiting for 290 -- work, or just about to go to sleep and wait for work. 291 292 Is_Waiting : array (1 .. Max_AST_Servers) of Boolean := (others => False); 293 -- An array of flags showing which AST server tasks are currently waiting 294 295 AST_Task_Ids : array (1 .. Max_AST_Servers) of ST.Task_Id; 296 -- Task Id's of allocated AST server tasks 297 298 task type AST_Server_Task (Num : Natural) is 299 pragma Priority (Priority'Last); 300 end AST_Server_Task; 301 -- Declaration for AST server task. This task has no entries, it is 302 -- controlled by sleep and wakeup calls at the task primitives level. 303 304 type AST_Server_Task_Ptr is access all AST_Server_Task; 305 -- Type used to allocate server tasks 306 307 ----------------------- 308 -- Local Subprograms -- 309 ----------------------- 310 311 procedure Allocate_New_AST_Server; 312 -- Allocate an additional AST server task 313 314 procedure Process_AST (Param : Long_Integer); 315 -- This is the central routine for processing all AST's, it is referenced 316 -- as the code address of all created AST_Handler values. See detailed 317 -- description in body to understand how it works to have a single such 318 -- procedure for all AST's even though it does not get any indication of 319 -- the entry involved passed as an explicit parameter. The single explicit 320 -- parameter Param is the parameter passed by the system with the AST. 321 322 ----------------------------- 323 -- Allocate_New_AST_Server -- 324 ----------------------------- 325 326 procedure Allocate_New_AST_Server is 327 Dummy : AST_Server_Task_Ptr; 328 pragma Unreferenced (Dummy); 329 330 begin 331 if Num_AST_Servers = Max_AST_Servers then 332 return; 333 334 else 335 -- Note: it is safe to increment Num_AST_Servers immediately, since 336 -- no one will try to activate this task until it indicates that it 337 -- is sleeping by setting its entry in Is_Waiting to True. 338 339 Num_AST_Servers := Num_AST_Servers + 1; 340 Dummy := new AST_Server_Task (Num_AST_Servers); 341 end if; 342 end Allocate_New_AST_Server; 343 344 --------------------- 345 -- AST_Server_Task -- 346 --------------------- 347 348 task body AST_Server_Task is 349 Taskid : ATID.Task_Id; 350 Entryno : Natural; 351 Param : aliased Long_Integer; 352 Self_Id : constant ST.Task_Id := ST.Self; 353 354 pragma Volatile (Param); 355 356 begin 357 -- By making this task independent of master, when the environment 358 -- task is finalizing, the AST_Server_Task will be notified that it 359 -- should terminate. 360 361 STU.Make_Independent; 362 363 -- Record our task Id for access by Process_AST 364 365 AST_Task_Ids (Num) := Self_Id; 366 367 -- Note: this entire task operates with the main task lock set, except 368 -- when it is sleeping waiting for work, or busy doing a rendezvous 369 -- with an AST server. This lock protects the data structures that 370 -- are shared by multiple instances of the server task. 371 372 Lock_AST (Self_Id); 373 374 -- This is the main infinite loop of the task. We go to sleep and 375 -- wait to be woken up by Process_AST when there is some work to do. 376 377 loop 378 Num_Waiting_AST_Servers := Num_Waiting_AST_Servers + 1; 379 380 Unlock_AST (Self_Id); 381 382 STI.Defer_Abort (Self_Id); 383 384 if SP.Single_Lock then 385 STPO.Lock_RTS; 386 end if; 387 388 STPO.Write_Lock (Self_Id); 389 390 Is_Waiting (Num) := True; 391 392 Self_Id.Common.State := ST.AST_Server_Sleep; 393 STPO.Sleep (Self_Id, ST.AST_Server_Sleep); 394 Self_Id.Common.State := ST.Runnable; 395 396 STPO.Unlock (Self_Id); 397 398 if SP.Single_Lock then 399 STPO.Unlock_RTS; 400 end if; 401 402 -- If the process is finalizing, Undefer_Abort will simply end 403 -- this task. 404 405 STI.Undefer_Abort (Self_Id); 406 407 -- We are awake, there is something to do 408 409 Lock_AST (Self_Id); 410 Num_Waiting_AST_Servers := Num_Waiting_AST_Servers - 1; 411 412 -- Loop here to service outstanding requests. We are always 413 -- locked on entry to this loop. 414 415 while AST_Service_Queue_Get /= AST_Service_Queue_Put loop 416 Taskid := AST_Service_Queue (AST_Service_Queue_Get).Taskid; 417 Entryno := AST_Service_Queue (AST_Service_Queue_Get).Entryno; 418 Param := AST_Service_Queue (AST_Service_Queue_Get).Param; 419 420 AST_Service_Queue_Get := AST_Service_Queue_Get + 1; 421 422 -- This is a manual expansion of the normal call simple code 423 424 declare 425 type AA is access all Long_Integer; 426 P : AA := Param'Unrestricted_Access; 427 428 function To_ST_Task_Id is new Ada.Unchecked_Conversion 429 (ATID.Task_Id, ST.Task_Id); 430 431 begin 432 Unlock_AST (Self_Id); 433 STR.Call_Simple 434 (Acceptor => To_ST_Task_Id (Taskid), 435 E => ST.Task_Entry_Index (Entryno), 436 Uninterpreted_Data => P'Address); 437 438 exception 439 when E : others => 440 System.IO.Put_Line ("%Debugging event"); 441 System.IO.Put_Line (Exception_Name (E) & 442 " raised when trying to deliver an AST."); 443 444 if Exception_Message (E)'Length /= 0 then 445 System.IO.Put_Line (Exception_Message (E)); 446 end if; 447 448 System.IO.Put_Line ("Task type is " & "Receiver_Type"); 449 System.IO.Put_Line ("Task id is " & ATID.Image (Taskid)); 450 end; 451 452 Lock_AST (Self_Id); 453 end loop; 454 end loop; 455 end AST_Server_Task; 456 457 ------------------------ 458 -- Create_AST_Handler -- 459 ------------------------ 460 461 function Create_AST_Handler 462 (Taskid : ATID.Task_Id; 463 Entryno : Natural) return System.Aux_DEC.AST_Handler 464 is 465 Attr_Ref : Attribute_Handle; 466 467 Process_AST_Ptr : constant AST_Handler := Process_AST'Access; 468 -- Reference to standard procedure descriptor for Process_AST 469 470 function To_Descriptor_Ref is new Ada.Unchecked_Conversion 471 (AST_Handler, Descriptor_Ref); 472 473 Original_Descriptor_Ref : constant Descriptor_Ref := 474 To_Descriptor_Ref (Process_AST_Ptr); 475 476 begin 477 if ATID.Is_Terminated (Taskid) then 478 raise Program_Error; 479 end if; 480 481 Attr_Ref := Reference (Taskid); 482 483 -- Allocate another server if supply is getting low 484 485 if Num_Waiting_AST_Servers < 2 then 486 Allocate_New_AST_Server; 487 end if; 488 489 -- No point in creating more if we have zillions waiting to 490 -- be serviced. 491 492 while AST_Service_Queue_Put - AST_Service_Queue_Get 493 > AST_Service_Queue_Limit 494 loop 495 delay 0.01; 496 end loop; 497 498 -- If no AST vector allocated, or the one we have is too short, then 499 -- allocate one of right size and initialize all entries except the 500 -- one we will use to unused. Note that the assignment automatically 501 -- frees the old allocated table if there is one. 502 503 if Attr_Ref.Vector = null 504 or else Attr_Ref.Vector'Length < Entryno 505 then 506 Attr_Ref.Vector := new AST_Handler_Vector (1 .. Entryno); 507 508 for E in 1 .. Entryno loop 509 Attr_Ref.Vector (E).Descriptor.Entry_Point := 510 Original_Descriptor_Ref.Entry_Point; 511 Attr_Ref.Vector (E).Descriptor.GP_Value := 512 Attr_Ref.Vector (E)'Address; 513 Attr_Ref.Vector (E).Original_Descriptor_Ref := 514 Original_Descriptor_Ref; 515 Attr_Ref.Vector (E).Taskid := Taskid; 516 Attr_Ref.Vector (E).Entryno := E; 517 end loop; 518 end if; 519 520 return To_AST_Handler (Attr_Ref.Vector (Entryno)'Unrestricted_Access); 521 end Create_AST_Handler; 522 523 ---------------------------- 524 -- Expand_AST_Packet_Pool -- 525 ---------------------------- 526 527 procedure Expand_AST_Packet_Pool 528 (Requested_Packets : Natural; 529 Actual_Number : out Natural; 530 Total_Number : out Natural) 531 is 532 pragma Unreferenced (Requested_Packets); 533 begin 534 -- The AST implementation of GNAT does not permit dynamic expansion 535 -- of the pool, so we simply add no entries and return the total. If 536 -- it is necessary to expand the allocation, then this package body 537 -- must be recompiled with a larger value for AST_Service_Queue_Size. 538 539 Actual_Number := 0; 540 Total_Number := AST_Service_Queue_Size; 541 end Expand_AST_Packet_Pool; 542 543 ----------------- 544 -- Process_AST -- 545 ----------------- 546 547 procedure Process_AST (Param : Long_Integer) is 548 549 Handler_Data_Ptr : AST_Handler_Data_Ref; 550 -- This variable is set to the address of the descriptor through 551 -- which Process_AST is called. Since the descriptor is part of 552 -- an AST_Handler value, this is also the address of this value, 553 -- from which we can obtain the task and entry number information. 554 555 function To_Address is new Ada.Unchecked_Conversion 556 (ST.Task_Id, System.Task_Primitives.Task_Address); 557 558 begin 559 -- Move the contrived GP into place so Taskid and Entryno 560 -- become available, then restore the true GP. 561 562 System.Machine_Code.Asm 563 (Template => "mov %0 = r1", 564 Outputs => AST_Handler_Data_Ref'Asm_Output 565 ("=r", Handler_Data_Ptr), 566 Volatile => True); 567 568 System.Machine_Code.Asm 569 (Template => "ld8 r1 = %0;;", 570 Inputs => System.Address'Asm_Input 571 ("m", Handler_Data_Ptr.Original_Descriptor_Ref.GP_Value), 572 Volatile => True); 573 574 AST_Service_Queue (AST_Service_Queue_Put) := AST_Instance' 575 (Taskid => Handler_Data_Ptr.Taskid, 576 Entryno => Handler_Data_Ptr.Entryno, 577 Param => Param); 578 579 -- OpenVMS Programming Concepts manual, chapter 8.2.3: 580 -- "Implicit synchronization can be achieved for data that is shared 581 -- for write by using only AST routines to write the data, since only 582 -- one AST can be running at any one time." 583 584 -- This subprogram runs at AST level so is guaranteed to be 585 -- called sequentially at a given access level. 586 587 AST_Service_Queue_Put := AST_Service_Queue_Put + 1; 588 589 -- Need to wake up processing task. If there is no waiting server 590 -- then we have temporarily run out, but things should still be 591 -- OK, since one of the active ones will eventually pick up the 592 -- service request queued in the AST_Service_Queue. 593 594 for J in 1 .. Num_AST_Servers loop 595 if Is_Waiting (J) then 596 Is_Waiting (J) := False; 597 598 -- Sleeps are handled by ASTs on VMS, so don't call Wakeup 599 600 STPOD.Interrupt_AST_Handler (To_Address (AST_Task_Ids (J))); 601 exit; 602 end if; 603 end loop; 604 end Process_AST; 605 606begin 607 STPO.Initialize_Lock (AST_Lock'Access, STPO.Global_Task_Level); 608end System.AST_Handling; 609