blob: 86d04025dbf8b22d70b33b0abd2a6323483505da [file] [log] [blame]
-- --
-- --
-- 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
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
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);
if Num_AST_Servers = Max_AST_Servers then
-- 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);
-- By making this task independent of master, when the environment
-- task is finalizing, the AST_Server_Task will be notified that it
-- should terminate.
-- 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.
Num_Waiting_AST_Servers := Num_Waiting_AST_Servers + 1;
Unlock_AST (Self_Id);
STI.Defer_Abort (Self_Id);
if SP.Single_Lock then
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
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
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);
Unlock_AST (Self_Id);
(Acceptor => To_ST_Task_Id (Taskid),
E => ST.Task_Entry_Index (Entryno),
Uninterpreted_Data => P'Address);
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));
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
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);
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
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
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
Attr_Ref.Vector := new AST_Handler_Vector (1 .. Entryno);
for E in 1 .. Entryno loop
Attr_Ref.Vector (E).Descriptor :=
Attr_Ref.Vector (E).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)
pragma Unreferenced (Requested_Packets);
-- 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);
(Template => "addl $27,0,%0",
Outputs => AST_Handler_Data_Ref'Asm_Output ("=r", Handler_Data_Ptr),
Volatile => True);
(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)));
end if;
end loop;
end Process_AST;
STPO.Initialize_Lock (AST_Lock'Access, STPO.Global_Task_Level);
end System.AST_Handling;