diff options
Diffstat (limited to 'gcc-4.4.0/gcc/ada/s-asthan-vms-alpha.adb')
| -rw-r--r-- | gcc-4.4.0/gcc/ada/s-asthan-vms-alpha.adb | 594 |
1 files changed, 0 insertions, 594 deletions
diff --git a/gcc-4.4.0/gcc/ada/s-asthan-vms-alpha.adb b/gcc-4.4.0/gcc/ada/s-asthan-vms-alpha.adb deleted file mode 100644 index 70f3cd8c9..000000000 --- a/gcc-4.4.0/gcc/ada/s-asthan-vms-alpha.adb +++ /dev/null @@ -1,594 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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-2009, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- 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 original 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 simultaneously 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.Task_Primitives.Task_Address); - - begin - System.Machine_Code.Asm - (Template => "addq $27,0,%0", - Outputs => AST_Handler_Data_Ref'Asm_Output ("=r", Handler_Data_Ptr), - Volatile => True); - - System.Machine_Code.Asm - (Template => "ldq $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; |