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