2008-05-30 Vladimir Makarov <vmakarov@redhat.com>

[official-gcc.git] / gcc / ada / s-asthan-vms-alpha.adb

------------------------------------------------------------------------------
--                                                                          --
--                        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-2008, 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 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;