| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT RUN-TIME COMPONENTS -- |
| -- -- |
| -- S Y S T E M . A S T _ H A N D L I N G -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1996-2006 Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 2, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING. If not, write -- |
| -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- |
| -- Boston, MA 02110-1301, USA. -- |
| -- -- |
| -- As a special exception, if other files instantiate generics from this -- |
| -- unit, or you link this unit with other files to produce an executable, -- |
| -- this unit does not by itself cause the resulting executable to be -- |
| -- covered by the GNU General Public License. This exception does not -- |
| -- however invalidate any other reasons why the executable file might be -- |
| -- covered by the GNU Public License. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| -- This is the OpenVMS/Alpha version. |
| |
| with System; use System; |
| |
| with System.IO; |
| |
| with System.Machine_Code; |
| with System.Parameters; |
| with System.Storage_Elements; |
| |
| with System.Tasking; |
| with System.Tasking.Rendezvous; |
| with System.Tasking.Initialization; |
| with System.Tasking.Utilities; |
| |
| with System.Task_Primitives; |
| with System.Task_Primitives.Operations; |
| with System.Task_Primitives.Operations.DEC; |
| |
| -- with Ada.Finalization; |
| -- removed, because of problem with controlled attribute ??? |
| |
| with Ada.Task_Attributes; |
| |
| with Ada.Exceptions; use Ada.Exceptions; |
| |
| with Ada.Unchecked_Conversion; |
| |
| package body System.AST_Handling is |
| |
| package ATID renames Ada.Task_Identification; |
| |
| package SP renames System.Parameters; |
| package ST renames System.Tasking; |
| package STR renames System.Tasking.Rendezvous; |
| package STI renames System.Tasking.Initialization; |
| package STU renames System.Tasking.Utilities; |
| |
| package SSE renames System.Storage_Elements; |
| package STPO renames System.Task_Primitives.Operations; |
| package STPOD renames System.Task_Primitives.Operations.DEC; |
| |
| AST_Lock : aliased System.Task_Primitives.RTS_Lock; |
| -- This is a global lock; it is used to execute in mutual exclusion |
| -- from all other AST tasks. It is only used by Lock_AST and |
| -- Unlock_AST. |
| |
| procedure Lock_AST (Self_ID : ST.Task_Id); |
| -- Locks out other AST tasks. Preceding a section of code by Lock_AST and |
| -- following it by Unlock_AST creates a critical region. |
| |
| procedure Unlock_AST (Self_ID : ST.Task_Id); |
| -- Releases lock previously set by call to Lock_AST. |
| -- All nested locks must be released before other tasks competing for the |
| -- tasking lock are released. |
| |
| -------------- |
| -- Lock_AST -- |
| -------------- |
| |
| procedure Lock_AST (Self_ID : ST.Task_Id) is |
| begin |
| STI.Defer_Abort_Nestable (Self_ID); |
| STPO.Write_Lock (AST_Lock'Access, Global_Lock => True); |
| end Lock_AST; |
| |
| ---------------- |
| -- Unlock_AST -- |
| ---------------- |
| |
| procedure Unlock_AST (Self_ID : ST.Task_Id) is |
| begin |
| STPO.Unlock (AST_Lock'Access, Global_Lock => True); |
| STI.Undefer_Abort_Nestable (Self_ID); |
| end Unlock_AST; |
| |
| --------------------------------- |
| -- AST_Handler Data Structures -- |
| --------------------------------- |
| |
| -- As noted in the private part of the spec of System.Aux_DEC, the |
| -- AST_Handler type is simply a pointer to a procedure that takes |
| -- a single 64bit parameter. The following is a local copy |
| -- of that definition. |
| |
| -- We need our own copy because we need to get our hands on this |
| -- and we cannot see the private part of System.Aux_DEC. We don't |
| -- want to be a child of Aux_Dec because of complications resulting |
| -- from the use of pragma Extend_System. We will use unchecked |
| -- conversions between the two versions of the declarations. |
| |
| type AST_Handler is access procedure (Param : Long_Integer); |
| |
| -- However, this declaration is somewhat misleading, since the values |
| -- referenced by AST_Handler values (all produced in this package by |
| -- calls to Create_AST_Handler) are highly stylized. |
| |
| -- The first point is that in VMS/Alpha, procedure pointers do not in |
| -- fact point to code, but rather to a 48-byte procedure descriptor. |
| -- So a value of type AST_Handler is in fact a pointer to one of these |
| -- 48-byte descriptors. |
| |
| type Descriptor_Type is new SSE.Storage_Array (1 .. 48); |
| for Descriptor_Type'Alignment use Standard'Maximum_Alignment; |
| pragma Warnings (Off, Descriptor_Type); |
| -- Suppress harmless warnings about alignment. |
| -- Should explain why this warning is harmless ??? |
| |
| type Descriptor_Ref is access all Descriptor_Type; |
| |
| -- Normally, there is only one such descriptor for a given procedure, but |
| -- it works fine to make a copy of the single allocated descriptor, and |
| -- use the copy itself, and we take advantage of this in the design here. |
| -- The idea is that AST_Handler values will all point to a record with the |
| -- following structure: |
| |
| -- Note: When we say it works fine, there is one delicate point, which |
| -- is that the code for the AST procedure itself requires the original |
| -- descriptor address. We handle this by saving the orignal descriptor |
| -- address in this structure and restoring in Process_AST. |
| |
| type AST_Handler_Data is record |
| Descriptor : Descriptor_Type; |
| Original_Descriptor_Ref : Descriptor_Ref; |
| Taskid : ATID.Task_Id; |
| Entryno : Natural; |
| end record; |
| |
| type AST_Handler_Data_Ref is access all AST_Handler_Data; |
| |
| function To_AST_Handler is new Ada.Unchecked_Conversion |
| (AST_Handler_Data_Ref, System.Aux_DEC.AST_Handler); |
| |
| -- Each time Create_AST_Handler is called, a new value of this record |
| -- type is created, containing a copy of the procedure descriptor for |
| -- the routine used to handle all AST's (Process_AST), and the Task_Id |
| -- and entry number parameters identifying the task entry involved. |
| |
| -- The AST_Handler value returned is a pointer to this record. Since |
| -- the record starts with the procedure descriptor, it can be used |
| -- by the system in the normal way to call the procedure. But now |
| -- when the procedure gets control, it can determine the address of |
| -- the procedure descriptor used to call it (since the ABI specifies |
| -- that this is left sitting in register r27 on entry), and then use |
| -- that address to retrieve the Task_Id and entry number so that it |
| -- knows on which entry to queue the AST request. |
| |
| -- The next issue is where are these records placed. Since we intend |
| -- to pass pointers to these records to asynchronous system service |
| -- routines, they have to be on the heap, which means we have to worry |
| -- about when to allocate them and deallocate them. |
| |
| -- We solve this problem by introducing a task attribute that points to |
| -- a vector, indexed by the entry number, of AST_Handler_Data records |
| -- for a given task. The pointer itself is a controlled object allowing |
| -- us to write a finalization routine that frees the referenced vector. |
| |
| -- An entry in this vector is either initialized (Entryno non-zero) and |
| -- can be used for any subsequent reference to the same entry, or it is |
| -- unused, marked by the Entryno value being zero. |
| |
| type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data; |
| type AST_Handler_Vector_Ref is access all AST_Handler_Vector; |
| |
| -- type AST_Vector_Ptr is new Ada.Finalization.Controlled with record |
| -- removed due to problem with controlled attribute, consequence is that |
| -- we have a memory leak if a task that has AST attribute entries is |
| -- terminated. ??? |
| |
| type AST_Vector_Ptr is record |
| Vector : AST_Handler_Vector_Ref; |
| end record; |
| |
| AST_Vector_Init : AST_Vector_Ptr; |
| -- Initial value, treated as constant, Vector will be null. |
| |
| package AST_Attribute is new Ada.Task_Attributes |
| (Attribute => AST_Vector_Ptr, |
| Initial_Value => AST_Vector_Init); |
| |
| use AST_Attribute; |
| |
| ----------------------- |
| -- AST Service Queue -- |
| ----------------------- |
| |
| -- The following global data structures are used to queue pending |
| -- AST requests. When an AST is signalled, the AST service routine |
| -- Process_AST is called, and it makes an entry in this structure. |
| |
| type AST_Instance is record |
| Taskid : ATID.Task_Id; |
| Entryno : Natural; |
| Param : Long_Integer; |
| end record; |
| -- The Taskid and Entryno indicate the entry on which this AST is to |
| -- be queued, and Param is the parameter provided from the AST itself. |
| |
| AST_Service_Queue_Size : constant := 256; |
| AST_Service_Queue_Limit : constant := 250; |
| type AST_Service_Queue_Index is mod AST_Service_Queue_Size; |
| -- Index used to refer to entries in the circular buffer which holds |
| -- active AST_Instance values. The upper bound reflects the maximum |
| -- number of AST instances that can be stored in the buffer. Since |
| -- these entries are immediately serviced by the high priority server |
| -- task that does the actual entry queuing, it is very unusual to have |
| -- any significant number of entries simulaneously queued. |
| |
| AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance; |
| pragma Volatile_Components (AST_Service_Queue); |
| -- The circular buffer used to store active AST requests. |
| |
| AST_Service_Queue_Put : AST_Service_Queue_Index := 0; |
| AST_Service_Queue_Get : AST_Service_Queue_Index := 0; |
| pragma Atomic (AST_Service_Queue_Put); |
| pragma Atomic (AST_Service_Queue_Get); |
| -- These two variables point to the next slots in the AST_Service_Queue |
| -- to be used for putting a new entry in and taking an entry out. This |
| -- is a circular buffer, so these pointers wrap around. If the two values |
| -- are equal the buffer is currently empty. The pointers are atomic to |
| -- ensure proper synchronization between the single producer (namely the |
| -- Process_AST procedure), and the single consumer (the AST_Service_Task). |
| |
| -------------------------------- |
| -- AST Server Task Structures -- |
| -------------------------------- |
| |
| -- The basic approach is that when an AST comes in, a call is made to |
| -- the Process_AST procedure. It queues the request in the service queue |
| -- and then wakes up an AST server task to perform the actual call to the |
| -- required entry. We use this intermediate server task, since the AST |
| -- procedure itself cannot wait to return, and we need some caller for |
| -- the rendezvous so that we can use the normal rendezvous mechanism. |
| |
| -- It would work to have only one AST server task, but then we would lose |
| -- all overlap in AST processing, and furthermore, we could get priority |
| -- inversion effects resulting in starvation of AST requests. |
| |
| -- We therefore maintain a small pool of AST server tasks. We adjust |
| -- the size of the pool dynamically to reflect traffic, so that we have |
| -- a sufficient number of server tasks to avoid starvation. |
| |
| Max_AST_Servers : constant Natural := 16; |
| -- Maximum number of AST server tasks that can be allocated |
| |
| Num_AST_Servers : Natural := 0; |
| -- Number of AST server tasks currently active |
| |
| Num_Waiting_AST_Servers : Natural := 0; |
| -- This is the number of AST server tasks that are either waiting for |
| -- work, or just about to go to sleep and wait for work. |
| |
| Is_Waiting : array (1 .. Max_AST_Servers) of Boolean := (others => False); |
| -- An array of flags showing which AST server tasks are currently waiting |
| |
| AST_Task_Ids : array (1 .. Max_AST_Servers) of ST.Task_Id; |
| -- Task Id's of allocated AST server tasks |
| |
| task type AST_Server_Task (Num : Natural) is |
| pragma Priority (Priority'Last); |
| end AST_Server_Task; |
| -- Declaration for AST server task. This task has no entries, it is |
| -- controlled by sleep and wakeup calls at the task primitives level. |
| |
| type AST_Server_Task_Ptr is access all AST_Server_Task; |
| -- Type used to allocate server tasks |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| procedure Allocate_New_AST_Server; |
| -- Allocate an additional AST server task |
| |
| procedure Process_AST (Param : Long_Integer); |
| -- This is the central routine for processing all AST's, it is referenced |
| -- as the code address of all created AST_Handler values. See detailed |
| -- description in body to understand how it works to have a single such |
| -- procedure for all AST's even though it does not get any indication of |
| -- the entry involved passed as an explicit parameter. The single explicit |
| -- parameter Param is the parameter passed by the system with the AST. |
| |
| ----------------------------- |
| -- Allocate_New_AST_Server -- |
| ----------------------------- |
| |
| procedure Allocate_New_AST_Server is |
| Dummy : AST_Server_Task_Ptr; |
| pragma Unreferenced (Dummy); |
| |
| begin |
| if Num_AST_Servers = Max_AST_Servers then |
| return; |
| |
| else |
| -- Note: it is safe to increment Num_AST_Servers immediately, since |
| -- no one will try to activate this task until it indicates that it |
| -- is sleeping by setting its entry in Is_Waiting to True. |
| |
| Num_AST_Servers := Num_AST_Servers + 1; |
| Dummy := new AST_Server_Task (Num_AST_Servers); |
| end if; |
| end Allocate_New_AST_Server; |
| |
| --------------------- |
| -- AST_Server_Task -- |
| --------------------- |
| |
| task body AST_Server_Task is |
| Taskid : ATID.Task_Id; |
| Entryno : Natural; |
| Param : aliased Long_Integer; |
| Self_Id : constant ST.Task_Id := ST.Self; |
| |
| pragma Volatile (Param); |
| |
| begin |
| -- By making this task independent of master, when the environment |
| -- task is finalizing, the AST_Server_Task will be notified that it |
| -- should terminate. |
| |
| STU.Make_Independent; |
| |
| -- Record our task Id for access by Process_AST |
| |
| AST_Task_Ids (Num) := Self_Id; |
| |
| -- Note: this entire task operates with the main task lock set, except |
| -- when it is sleeping waiting for work, or busy doing a rendezvous |
| -- with an AST server. This lock protects the data structures that |
| -- are shared by multiple instances of the server task. |
| |
| Lock_AST (Self_Id); |
| |
| -- This is the main infinite loop of the task. We go to sleep and |
| -- wait to be woken up by Process_AST when there is some work to do. |
| |
| loop |
| Num_Waiting_AST_Servers := Num_Waiting_AST_Servers + 1; |
| |
| Unlock_AST (Self_Id); |
| |
| STI.Defer_Abort (Self_Id); |
| |
| if SP.Single_Lock then |
| STPO.Lock_RTS; |
| end if; |
| |
| STPO.Write_Lock (Self_Id); |
| |
| Is_Waiting (Num) := True; |
| |
| Self_Id.Common.State := ST.AST_Server_Sleep; |
| STPO.Sleep (Self_Id, ST.AST_Server_Sleep); |
| Self_Id.Common.State := ST.Runnable; |
| |
| STPO.Unlock (Self_Id); |
| |
| if SP.Single_Lock then |
| STPO.Unlock_RTS; |
| end if; |
| |
| -- If the process is finalizing, Undefer_Abort will simply end |
| -- this task. |
| |
| STI.Undefer_Abort (Self_Id); |
| |
| -- We are awake, there is something to do! |
| |
| Lock_AST (Self_Id); |
| Num_Waiting_AST_Servers := Num_Waiting_AST_Servers - 1; |
| |
| -- Loop here to service outstanding requests. We are always |
| -- locked on entry to this loop. |
| |
| while AST_Service_Queue_Get /= AST_Service_Queue_Put loop |
| Taskid := AST_Service_Queue (AST_Service_Queue_Get).Taskid; |
| Entryno := AST_Service_Queue (AST_Service_Queue_Get).Entryno; |
| Param := AST_Service_Queue (AST_Service_Queue_Get).Param; |
| |
| AST_Service_Queue_Get := AST_Service_Queue_Get + 1; |
| |
| -- This is a manual expansion of the normal call simple code |
| |
| declare |
| type AA is access all Long_Integer; |
| P : AA := Param'Unrestricted_Access; |
| |
| function To_ST_Task_Id is new Ada.Unchecked_Conversion |
| (ATID.Task_Id, ST.Task_Id); |
| |
| begin |
| Unlock_AST (Self_Id); |
| STR.Call_Simple |
| (Acceptor => To_ST_Task_Id (Taskid), |
| E => ST.Task_Entry_Index (Entryno), |
| Uninterpreted_Data => P'Address); |
| |
| exception |
| when E : others => |
| System.IO.Put_Line ("%Debugging event"); |
| System.IO.Put_Line (Exception_Name (E) & |
| " raised when trying to deliver an AST."); |
| |
| if Exception_Message (E)'Length /= 0 then |
| System.IO.Put_Line (Exception_Message (E)); |
| end if; |
| |
| System.IO.Put_Line ("Task type is " & "Receiver_Type"); |
| System.IO.Put_Line ("Task id is " & ATID.Image (Taskid)); |
| end; |
| |
| Lock_AST (Self_Id); |
| end loop; |
| end loop; |
| end AST_Server_Task; |
| |
| ------------------------ |
| -- Create_AST_Handler -- |
| ------------------------ |
| |
| function Create_AST_Handler |
| (Taskid : ATID.Task_Id; |
| Entryno : Natural) return System.Aux_DEC.AST_Handler |
| is |
| Attr_Ref : Attribute_Handle; |
| |
| Process_AST_Ptr : constant AST_Handler := Process_AST'Access; |
| -- Reference to standard procedure descriptor for Process_AST |
| |
| function To_Descriptor_Ref is new Ada.Unchecked_Conversion |
| (AST_Handler, Descriptor_Ref); |
| |
| Original_Descriptor_Ref : constant Descriptor_Ref := |
| To_Descriptor_Ref (Process_AST_Ptr); |
| |
| begin |
| if ATID.Is_Terminated (Taskid) then |
| raise Program_Error; |
| end if; |
| |
| Attr_Ref := Reference (Taskid); |
| |
| -- Allocate another server if supply is getting low |
| |
| if Num_Waiting_AST_Servers < 2 then |
| Allocate_New_AST_Server; |
| end if; |
| |
| -- No point in creating more if we have zillions waiting to |
| -- be serviced. |
| |
| while AST_Service_Queue_Put - AST_Service_Queue_Get |
| > AST_Service_Queue_Limit |
| loop |
| delay 0.01; |
| end loop; |
| |
| -- If no AST vector allocated, or the one we have is too short, then |
| -- allocate one of right size and initialize all entries except the |
| -- one we will use to unused. Note that the assignment automatically |
| -- frees the old allocated table if there is one. |
| |
| if Attr_Ref.Vector = null |
| or else Attr_Ref.Vector'Length < Entryno |
| then |
| Attr_Ref.Vector := new AST_Handler_Vector (1 .. Entryno); |
| |
| for E in 1 .. Entryno loop |
| Attr_Ref.Vector (E).Descriptor := |
| Original_Descriptor_Ref.all; |
| Attr_Ref.Vector (E).Original_Descriptor_Ref := |
| Original_Descriptor_Ref; |
| Attr_Ref.Vector (E).Taskid := Taskid; |
| Attr_Ref.Vector (E).Entryno := E; |
| end loop; |
| end if; |
| |
| return To_AST_Handler (Attr_Ref.Vector (Entryno)'Unrestricted_Access); |
| end Create_AST_Handler; |
| |
| ---------------------------- |
| -- Expand_AST_Packet_Pool -- |
| ---------------------------- |
| |
| procedure Expand_AST_Packet_Pool |
| (Requested_Packets : in Natural; |
| Actual_Number : out Natural; |
| Total_Number : out Natural) |
| is |
| pragma Unreferenced (Requested_Packets); |
| begin |
| -- The AST implementation of GNAT does not permit dynamic expansion |
| -- of the pool, so we simply add no entries and return the total. If |
| -- it is necessary to expand the allocation, then this package body |
| -- must be recompiled with a larger value for AST_Service_Queue_Size. |
| |
| Actual_Number := 0; |
| Total_Number := AST_Service_Queue_Size; |
| end Expand_AST_Packet_Pool; |
| |
| ----------------- |
| -- Process_AST -- |
| ----------------- |
| |
| procedure Process_AST (Param : Long_Integer) is |
| |
| Handler_Data_Ptr : AST_Handler_Data_Ref; |
| -- This variable is set to the address of the descriptor through |
| -- which Process_AST is called. Since the descriptor is part of |
| -- an AST_Handler value, this is also the address of this value, |
| -- from which we can obtain the task and entry number information. |
| |
| function To_Address is new Ada.Unchecked_Conversion |
| (ST.Task_Id, System.Address); |
| |
| begin |
| System.Machine_Code.Asm |
| (Template => "addl $27,0,%0", |
| Outputs => AST_Handler_Data_Ref'Asm_Output ("=r", Handler_Data_Ptr), |
| Volatile => True); |
| |
| System.Machine_Code.Asm |
| (Template => "ldl $27,%0", |
| Inputs => Descriptor_Ref'Asm_Input |
| ("m", Handler_Data_Ptr.Original_Descriptor_Ref), |
| Volatile => True); |
| |
| AST_Service_Queue (AST_Service_Queue_Put) := AST_Instance' |
| (Taskid => Handler_Data_Ptr.Taskid, |
| Entryno => Handler_Data_Ptr.Entryno, |
| Param => Param); |
| |
| -- OpenVMS Programming Concepts manual, chapter 8.2.3: |
| -- "Implicit synchronization can be achieved for data that is shared |
| -- for write by using only AST routines to write the data, since only |
| -- one AST can be running at any one time." |
| |
| -- This subprogram runs at AST level so is guaranteed to be |
| -- called sequentially at a given access level. |
| |
| AST_Service_Queue_Put := AST_Service_Queue_Put + 1; |
| |
| -- Need to wake up processing task. If there is no waiting server |
| -- then we have temporarily run out, but things should still be |
| -- OK, since one of the active ones will eventually pick up the |
| -- service request queued in the AST_Service_Queue. |
| |
| for J in 1 .. Num_AST_Servers loop |
| if Is_Waiting (J) then |
| Is_Waiting (J) := False; |
| |
| -- Sleeps are handled by ASTs on VMS, so don't call Wakeup. |
| |
| STPOD.Interrupt_AST_Handler (To_Address (AST_Task_Ids (J))); |
| exit; |
| end if; |
| end loop; |
| end Process_AST; |
| |
| begin |
| STPO.Initialize_Lock (AST_Lock'Access, STPO.Global_Task_Level); |
| end System.AST_Handling; |
