Subversion Repositories openrisc_me

------------------------------------------------------------------------------
--                                                                          --
--                        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;
 
   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
 
      pragma Warnings (Off, "*alignment*");
      --  Suppress harmless warnings about alignment.
      --  Should explain why this warning is harmless ???
 
      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);
 
      pragma Warnings (On, "*alignment*");
 
   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;