diff options
Diffstat (limited to 'gcc-4.3.1/gcc/ada/s-asthan-vms-alpha.adb')
| -rw-r--r-- | gcc-4.3.1/gcc/ada/s-asthan-vms-alpha.adb | 596 |
1 files changed, 596 insertions, 0 deletions
diff --git a/gcc-4.3.1/gcc/ada/s-asthan-vms-alpha.adb b/gcc-4.3.1/gcc/ada/s-asthan-vms-alpha.adb new file mode 100644 index 000000000..b6b8395d4 --- /dev/null +++ b/gcc-4.3.1/gcc/ada/s-asthan-vms-alpha.adb @@ -0,0 +1,596 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2007, 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 : 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; |