From: Arnaud Charlet Date: Thu, 10 Feb 2005 13:55:33 +0000 (+0100) Subject: re PR ada/16592 (Ada tools don't use the newly built shared libraries) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=3536d406b5a5d065dcfc43b434f99118eab96fa9;p=gcc.git re PR ada/16592 (Ada tools don't use the newly built shared libraries) * s-asthan-vms.adb: Removed. * s-asthan-vms-alpha.adb: Added. * Makefile.in [VMS] (LN,LN_S): Define as cp -p Rename s-asthan-vms.adb to s-asthan-vms-alpha.adb. [VMS]: Add translations for g-enblsp.adb. (LIBGNAT_SRCS): Add seh_init.c. (LIBGNAT_OBJS): Add seh_init.o. PR ada/16592 Link all gnat tools with -static-libgcc, since -shared-libgcc is now used by default on some systems (e.g. linux with recent binutils). Remove references to Makefile.prolog/generic, no longer used. From-SVN: r94818 --- diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index edf39b63f49..1e6e5350f3d 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -163,6 +163,7 @@ GCC_CFLAGS = $(INTERNAL_CFLAGS) $(X_CFLAGS) $(T_CFLAGS) $(CFLAGS) program_transform_name = objdir = . +target_alias=@target_alias@ target=@target@ xmake_file = @xmake_file@ tmake_file = @tmake_file@ @@ -1174,6 +1175,8 @@ ifeq ($(strip $(filter-out alpha% ia64 dec hp vms% openvms% alphavms%,$(host))), soext = .exe hyphen = _ +LN = cp -p +LN_S = cp -p ifeq ($(strip $(filter-out ia64 hp vms% openvms%,$(targ))),) AR = iar @@ -1188,6 +1191,7 @@ endif ifeq ($(strip $(filter-out alpha% ia64 dec hp vms% openvms% alphavms%,$(targ))),) ifeq ($(strip $(filter-out ia64 hp vms% openvms%,$(targ))),) LIBGNAT_TARGET_PAIRS_AUX1 = \ + g-enblsp.adb 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; diff --git a/gcc/ada/s-asthan-vms.adb b/gcc/ada/s-asthan-vms.adb deleted file mode 100644 index 7d66ad822c1..00000000000 --- a/gcc/ada/s-asthan-vms.adb +++ /dev/null @@ -1,597 +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-2004 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, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, 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.Task_Identification; - -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;