garlic_6.0.1_90ef4b6f/Garlic/s-parint.adb

------------------------------------------------------------------------------
--                                                                          --
--                            GLADE COMPONENTS                              --
--                                                                          --
--           S Y S T E M . P A R T I T I O N _ I N T E R F A C E            --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--         Copyright (C) 1996-2020 Free Software Foundation, Inc.           --
--                                                                          --
-- GARLIC 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.  GARLIC is distributed  in the hope that  it will be  useful,  but --
-- WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHANTABI- --
-- LITY 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 GARLIC;  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.                                      --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Unchecked_Deallocation;
with Ada.Unchecked_Conversion;

with System.HTable;            use System.HTable;

with System.Garlic.Debug;      use System.Garlic.Debug;
with System.Garlic.Exceptions; use System.Garlic.Exceptions;
with System.Garlic.Heart;      use System.Garlic.Heart;
with System.Garlic.Options;    use System.Garlic.Options;
with System.Garlic.Partitions; use System.Garlic.Partitions;
with System.Garlic.Storages;   use System.Garlic.Storages;
with System.Garlic.Types;      use System.Garlic.Types;
with System.Garlic.Soft_Links;

with System.Garlic.Startup;
pragma Elaborate_All (System.Garlic.Startup);
pragma Warnings (Off, System.Garlic.Startup);

with System.Garlic.Utils;     use System.Garlic.Utils;

package body System.Partition_Interface is

   use Ada.Exceptions, Interfaces;
   use System.Garlic.Units;

   package SG  renames System.Garlic;

   Private_Debug_Key : constant Debug_Key :=
     Debug_Initialize ("S_PARINT", "(s-parint): ");

   procedure D
     (Message : String;
      Key     : Debug_Key := Private_Debug_Key)
     renames Print_Debug_Info;

   function Convert is
      new Ada.Unchecked_Conversion
     (RPC_Receiver, System.Address);

   procedure Setup_RAS_Proxies
     (Subprograms : RCI_Subp_Info_Array;
      Receiver    : System.Address);
   --  Initialize the Receiver and Subp_Id information stored in local
   --  RCI subprogram proxy objects.

   procedure Complete_Termination (Termination : Termination_Type);
   --  Select the correct soft link

   function Different (V1, V2 : String) return Boolean;
   --  Compare two version ids. If one of these version ids is a string
   --  of blank characters then they will be considered as identical.

   function Get_Unit_Version (Name : String; RCI : Boolean) return String;
   --  When RCI, get active version. Otherwise, get passive version.

   type Hash_Index is range 0 .. 100;
   function Hash (K : RACW_Stub_Type_Access) return Hash_Index;

   function Compare_Content (Left, Right : RACW_Stub_Type_Access)
     return Boolean;

   package Objects_HTable is
      new Simple_HTable (Header_Num => Hash_Index,
                         Element    => RACW_Stub_Type_Access,
                         No_Element => null,
                         Key        => RACW_Stub_Type_Access,
                         Hash       => Hash,
                         Equal      => Compare_Content);

   --  This is a list of caller units whose Version_ID needs to check.

   type Caller_Node;
   type Caller_List is access Caller_Node;
   type Caller_Node is
      record
         Name    : String_Access;
         Version : String_Access;
         RCI     : Boolean;
         Next    : Caller_List;
      end record;
   Callers : Caller_List;

   procedure Free is new Ada.Unchecked_Deallocation (Caller_Node, Caller_List);

   procedure Raise_Communication_Error (S : String);
   procedure Raise_Communication_Error (E : access Error_Type);
   --  Raise System.RPC.Communication_Error with an explicit error message
   --  or an Error_Type variable.

   -----------
   -- Check --
   -----------

   procedure Check
     (Name    : Unit_Name;
      Version : String;
      RCI     : Boolean := True)
   is
      Caller : constant Caller_List := new Caller_Node;
   begin
      Caller.Name    := new String'(Name);
      Caller.Version := new String'(Version);
      Caller.RCI     := RCI;
      Caller.Next    := Callers;
      Callers        := Caller;
   end Check;

   ---------------------
   -- Compare_Content --
   ---------------------

   function Compare_Content (Left, Right : RACW_Stub_Type_Access)
     return Boolean
   is
   begin
      return Left /= null and then Right /= null and then Left.all = Right.all;
   end Compare_Content;

   --------------------------
   -- Complete_Termination --
   --------------------------

   procedure Complete_Termination (Termination : Termination_Type) is
   begin
      case Termination is
         when Local_Termination  =>
            SG.Soft_Links.Local_Termination;
         when Global_Termination =>
            SG.Soft_Links.Global_Termination;
         when others => null;
      end case;
      Delete_Termination_Sanity_File;
   end Complete_Termination;

   ---------------
   -- Different --
   ---------------

   function Different (V1, V2 : String) return Boolean is

      function Not_Null_Version (V : String) return Boolean;
      --  Return true when V is not a string of blank characters

      ----------------------
      -- Not_Null_Version --
      ----------------------

      function Not_Null_Version (V : String) return Boolean is
         Null_String : constant String (V'Range) := (others => ' ');
      begin
         return V /= Null_String;
      end Not_Null_Version;

   begin
      return     Not_Null_Version (V1)
        and then Not_Null_Version (V2)
        and then V1 /= V2;
   end Different;

   ---------------------------------
   -- Elaborate_Passive_Partition --
   ---------------------------------

   procedure Elaborate_Passive_Partition
     (Partition : RPC.Partition_ID)
   is
      Error : aliased Error_Type;

   begin
      Register_Units_On_Boot_Server (Partition_ID (Partition), Error);
      if Found (Error) then
         Raise_Communication_Error (Error'Access);
      end if;
   end Elaborate_Passive_Partition;

   -----------------------------
   -- Get_Active_Partition_ID --
   -----------------------------

   function Get_Active_Partition_ID
     (Name : Unit_Name) return RPC.Partition_ID
   is
      N : String := Name;
      E : aliased Error_Type;
      P : Partition_ID;

   begin
      pragma Debug (D ("Request Get_Active_Partition_ID"));

      To_Lower (N);
      Get_Partition (Get_Unit_Id (N), P, E);
      if Found (E) then
         Raise_Communication_Error (E'Access);
      end if;

      D ("Unit " & N & " is configured on" & P'Img);

      return RPC.Partition_ID (P);
   end Get_Active_Partition_ID;

   ------------------------
   -- Get_Active_Version --
   ------------------------

   function Get_Active_Version (Name : Unit_Name) return String is
      N : String := Name;
      V : Version_Type;
      E : aliased Error_Type;
   begin
      pragma Debug (D ("Request Get_Active_Version"));

      To_Lower (N);
      Get_Version (Get_Unit_Id (N), V, E);
      if Found (E) then
         Raise_Communication_Error (E'Access);
      end if;

      return String (V);
   end Get_Active_Version;

   ----------------------------
   -- Get_Local_Partition_ID --
   ----------------------------

   function Get_Local_Partition_ID return RPC.Partition_ID is
   begin
      return RPC.Partition_ID (Self_PID);
   end Get_Local_Partition_ID;

   ------------------------
   -- Get_Partition_Name --
   ------------------------

   function Get_Partition_Name (Partition : Integer) return String is
      Name  : String_Access;
      Error : aliased Error_Type;
   begin
      SG.Partitions.Get_Name (Partition_ID (Partition), Name, Error);
      if Found (Error) then
         Raise_Communication_Error (Error'Access);
      end if;
      return Name.all;
   end Get_Partition_Name;

   ------------------------------
   -- Get_Passive_Partition_ID --
   ------------------------------

   function Get_Passive_Partition_ID
     (Name : Unit_Name) return RPC.Partition_ID is
   begin
      return Get_Active_Partition_ID (Name);
   end Get_Passive_Partition_ID;

   -------------------------
   -- Get_Passive_Version --
   -------------------------

   function Get_Passive_Version (Name : Unit_Name) return String is
   begin
      return Get_Active_Version (Name);
   end Get_Passive_Version;

   ------------------
   -- Get_RAS_Info --
   ------------------

   procedure Get_RAS_Info
     (Name          : Unit_Name;
      Subp_Id       : Subprogram_Id;
      Proxy_Address : out Interfaces.Unsigned_64)
   is
      subtype U64 is Interfaces.Unsigned_64;

      Subp_Info : RCI_Subp_Info_Access;
      Unit      : constant Unit_Id := Get_Unit_Id (Name);
      Origin    : Partition_ID;
      Error     : Error_Type;
   begin
      Proxy_Address := U64 (System.Null_Address);

      Get_Partition (Unit, Origin, Error);
      if Found (Error) then
         raise Constraint_Error;
      end if;
      if Origin = Self_PID then
         Subp_Info := Get_Subprogram_Info (Unit, Subp_Id);
         if Subp_Info /= null then
            Proxy_Address := U64 (Subp_Info.Addr);
         end if;
      else
         declare
            use System.RPC;

            Receiver : U64;
            Error : Error_Type;

            Params  : aliased Params_Stream_Type (0);
            Returns : aliased Params_Stream_Type (0);
            Except  : Ada.Exceptions.Exception_Occurrence;
         begin
            Get_Receiver (Unit, Receiver, Error);
            if Found (Error) then
               raise Constraint_Error;
            end if;

            U64'Write (Params'Access, Receiver);
            Subprogram_Id'Write (Params'Access, 1);
            --  Special subprogram id: Lookup RAS information

            Subprogram_Id'Write (Params'Access, Subp_Id);

            Do_RPC (RPC.Partition_ID (Origin), Params'Access, Returns'Access);
            Ada.Exceptions.Exception_Occurrence'Read (Returns'Access, Except);
            Ada.Exceptions.Reraise_Occurrence (Except);
            U64'Read (Returns'Access, Proxy_Address);
         end;
      end if;
   end Get_RAS_Info;

   ------------------------------
   -- Get_RCI_Package_Receiver --
   ------------------------------

   function Get_RCI_Package_Receiver (Name : Unit_Name) return Unsigned_64 is
      N : String := Name;
      R : Unsigned_64;
      E : aliased Error_Type;
   begin
      pragma Debug (D ("Request Get_Package_Receiver"));

      To_Lower (N);
      Get_Receiver (Get_Unit_Id (N), R, E);
      if Found (E) then
         Raise_Communication_Error (E'Access);
      end if;

      return R;
   end Get_RCI_Package_Receiver;

   -------------------------------
   -- Get_Unique_Remote_Pointer --
   -------------------------------

   procedure Get_Unique_Remote_Pointer
     (Handler : in out RACW_Stub_Type_Access)
   is
      Answer : RACW_Stub_Type_Access;
   begin
      System.Garlic.Soft_Links.Enter_Critical_Section;
      Answer := Objects_HTable.Get (Handler);
      if Answer = null then
         Answer := new RACW_Stub_Type'(Handler.all);
         Objects_HTable.Set (Answer, Answer);
      end if;
      Handler := Answer;
      System.Garlic.Soft_Links.Leave_Critical_Section;
   end Get_Unique_Remote_Pointer;

   ----------------------
   -- Get_Unit_Version --
   ----------------------

   function Get_Unit_Version (Name : String; RCI : Boolean) return String is
   begin
      if RCI then
         return Get_Active_Version (Name);
      else
         return Get_Passive_Version (Name);
      end if;
   end Get_Unit_Version;

   ----------
   -- Hash --
   ----------

   function Hash (K : RACW_Stub_Type_Access) return Hash_Index is
   begin
      return
        Hash_Index (K.Addr mod Interfaces.Unsigned_64 (Hash_Index'Last + 1));
   end Hash;

   -------------------------------
   -- Raise_Communication_Error --
   -------------------------------

   procedure Raise_Communication_Error (S : String) is
   begin
      Ada.Exceptions.Raise_Exception (RPC.Communication_Error'Identity, S);
   end Raise_Communication_Error;

   -------------------------------
   -- Raise_Communication_Error --
   -------------------------------

   procedure Raise_Communication_Error (E : access Error_Type) is
   begin
      Raise_Communication_Error (Content (E));
   end Raise_Communication_Error;

   ------------------------------------
   -- Raise_Program_Error_For_E_4_18 --
   ------------------------------------

   procedure Raise_Program_Error_For_E_4_18 is
   begin
      Ada.Exceptions.Raise_Exception (Program_Error'Identity,
        "Illegal usage of remote access to class-wide type. See RM E.4(18)");
   end Raise_Program_Error_For_E_4_18;

   -------------------------------------
   -- Raise_Program_Error_Unknown_Tag --
   -------------------------------------

   procedure Raise_Program_Error_Unknown_Tag
     (E : Ada.Exceptions.Exception_Occurrence)
   is
   begin
      Ada.Exceptions.Raise_Exception
        (Program_Error'Identity, Ada.Exceptions.Exception_Message (E));
   end Raise_Program_Error_Unknown_Tag;

   ------------------------------
   -- Register_Passive_Package --
   ------------------------------

   procedure Register_Passive_Package
     (Name    : Unit_Name;
      Version : String := "")
   is
      N : String       := Name;
      V : constant Version_Type := Version_Type (Version);
      E : aliased Error_Type;

   begin
      To_Lower (N);

      pragma Debug (D ("Register local shared passive unit " & N));

      Register_Unit (Self_PID, N, 0, V, System.Null_Address, 0);
      Register_Package (N, Self_PID, E);
      if Found (E) then
         Raise_Communication_Error (E'Access);
      end if;
   end Register_Passive_Package;

   ---------------------------------------------------
   -- Register_Passive_Package_On_Passive_Partition --
   ---------------------------------------------------

   procedure Register_Passive_Package_On_Passive_Partition
     (Partition : RPC.Partition_ID;
      Name      : Unit_Name;
      Version   : String := "")
     is
      N : String       := Name;
      V : constant Version_Type := Version_Type (Version);
      P : constant Partition_ID := Partition_ID (Partition);

   begin
      To_Lower (N);

      pragma Debug (D ("Register " & N & " on passive partition" & P'Img));

      Register_Unit (P, N, 0, V, System.Null_Address, 0);
   end Register_Passive_Package_On_Passive_Partition;

   --------------------------------
   -- Register_Passive_Partition --
   --------------------------------

   procedure Register_Passive_Partition
     (Partition : out RPC.Partition_ID;
      Name      : String;
      Location  : String)
   is
      Error : aliased Error_Type;

   begin
      Register_Passive_Partition
        (Partition_ID (Partition), Name, Location, Error);
      if Found (Error) then
         Raise_Communication_Error (Error'Access);
      end if;

      Register_Partition (Partition_ID (Partition), Location, Error);
      if Found (Error) then
         Raise_Communication_Error (Error'Access);
      end if;
   end Register_Passive_Partition;

   -----------------------------
   -- Register_Receiving_Stub --
   -----------------------------

   procedure Register_Receiving_Stub
     (Name          : Unit_Name;
      Receiver      : RPC_Receiver;
      Version       : String := "";
      Subp_Info     : System.Address;
      Subp_Info_Len : Integer)
   is
      Receiver_Address : constant System.Address :=
        Convert (Receiver);
      N : String       := Name;
      V : constant Version_Type := Version_Type (Version);
      R : constant Unsigned_64  := Unsigned_64 (Receiver_Address);

      subtype Subprogram_Array is RCI_Subp_Info_Array
        (System.Garlic.Units.First_RCI_Subprogram_Id ..
         System.Garlic.Units.First_RCI_Subprogram_Id + Subp_Info_Len - 1);
      Subprograms : Subprogram_Array;
      for Subprograms'Address use Subp_Info;
      pragma Import (Ada, Subprograms);
   begin
      pragma Debug (D ("Register receiving stub"));

      To_Lower (N);
      Register_Unit (Self_PID, N, R, V, Subp_Info, Subp_Info_Len);
      Setup_RAS_Proxies (Subprograms, Receiver_Address);
   end Register_Receiving_Stub;

   -----------------
   -- RCI_Locator --
   -----------------

   package body RCI_Locator is

      Name : String := RCI_Name;
      Unit : Unit_Id;
      Init : Boolean := False;

      -----------------------------
      -- Get_Active_Partition_ID --
      -----------------------------

      function Get_Active_Partition_ID return RPC.Partition_ID is
         Partition : Partition_ID;
         Error     : aliased Error_Type;
      begin
         if not Init then
            Init := True;
            To_Lower (Name);
            Unit := Get_Unit_Id (Name);
         end if;
         Get_Partition (Unit, Partition, Error);
         if Found (Error) then
            Raise_Communication_Error (Error'Access);
         end if;
         return RPC.Partition_ID (Partition);
      end Get_Active_Partition_ID;

      ------------------------------
      -- Get_RCI_Package_Receiver --
      ------------------------------

      function Get_RCI_Package_Receiver return Unsigned_64 is
         Receiver : Unsigned_64;
         Error    : aliased Error_Type;
      begin
         if not Init then
            Init := True;
            To_Lower (Name);
            Unit := Get_Unit_Id (Name);
         end if;
         Get_Receiver (Unit, Receiver, Error);
         if Found (Error) then
            Raise_Communication_Error (Error'Access);
         end if;
         return Receiver;
      end Get_RCI_Package_Receiver;

   end RCI_Locator;

   ---------
   -- Run --
   ---------

   procedure Run (Main : Main_Subprogram_Type := null) is
      Caller   : Caller_List := Callers;
      Dummy    : Caller_List;
      Error    : aliased Error_Type;
      Pkg_Data : Shared_Data_Access;

   begin
      SG.Heart.Complete_Elaboration;
      D ("Complete elaboration");

      Register_Units_On_Boot_Server (Self_PID, Error);
      if Found (Error) then
         Raise_Communication_Error (Error'Access);
      end if;

      RPC.Establish_RPC_Receiver (RPC.Partition_ID (Self_PID), null);

      while Caller /= null loop
         D ("Check " & Caller.Name.all & " version consistency");
         if Different (Caller.Version.all,
                       Get_Unit_Version (Caller.Name.all, Caller.RCI))
         then

            --  If not boot partition, then terminate without waiting for
            --  boot partition request.

            if not Is_Boot_Server then
               Set_Termination (Local_Termination);
            end if;

            Ada.Exceptions.Raise_Exception
              (Program_Error'Identity,
               "Versions differ for unit """ &
               Caller.Name.all & """");

         end if;

         --  For shared passive units, check that their storage support
         --  has been correctly setup.

         if not Caller.RCI then
            Lookup_Package (Caller.Name.all, Pkg_Data, Error);
            if Found (Error)  then
               Ada.Exceptions.Raise_Exception
                 (Program_Error'Identity, Content (Error'Access));
            end if;
         end if;

         Destroy (Caller.Version);
         Destroy (Caller.Name);
         Dummy  := Caller;
         Caller := Caller.Next;
         Free (Dummy);
      end loop;

      D ("Execute partition main subprogram");
      if Main /= null then
         Main.all;
      end if;

      D ("Watch for termination");
      Complete_Termination (SG.Options.Termination);
   exception
      when Occurrence : others =>
         D ("Handle exception " & Exception_Name (Occurrence) &
            " in partition main subprogram");
      Complete_Termination (SG.Options.Termination);
      raise;
   end Run;

   --------------------
   -- Same_Partition --
   --------------------

   function Same_Partition
      (Left  : access RACW_Stub_Type;
       Right : access RACW_Stub_Type) return Boolean
   is
      use type System.RPC.Partition_ID;
   begin
      return Left.Origin = Right.Origin;
   end Same_Partition;

   -----------------------
   -- Setup_RAS_Proxies --
   -----------------------

   procedure Setup_RAS_Proxies
     (Subprograms : RCI_Subp_Info_Array;
      Receiver    : System.Address)
   is
      function To_Proxy is
         new Ada.Unchecked_Conversion (System.Address, RAS_Proxy_Type_Access);
   begin
      for Subp_Id in Subprograms'Range loop
         To_Proxy (Subprograms (Subp_Id).Addr).Receiver := Receiver;
         To_Proxy (Subprograms (Subp_Id).Addr).Subp_Id  :=
           Subprogram_Id (Subp_Id);
      end loop;
   end Setup_RAS_Proxies;

end System.Partition_Interface;