+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . R P C --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-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. --
--- --
-------------------------------------------------------------------------------
-
--- Version for ???
-
-with Unchecked_Deallocation;
-with Ada.Streams;
-
-with System.RPC.Net_Trace;
-with System.RPC.Garlic;
-with System.RPC.Streams;
-pragma Elaborate (System.RPC.Garlic);
-
-package body System.RPC is
-
- -- ??? general note: the debugging calls are very heavy, especially
- -- those that create exception handlers in every procedure. Do we
- -- really still need all this stuff?
-
- use type Ada.Streams.Stream_Element_Count;
- use type Ada.Streams.Stream_Element_Offset;
-
- use type Garlic.Protocol_Access;
- use type Garlic.Lock_Method;
-
- Max_Of_Message_Id : constant := 127;
-
- subtype Message_Id_Type is
- Integer range -Max_Of_Message_Id .. Max_Of_Message_Id;
- -- A message id is either a request id or reply id. A message id is
- -- provided with a message to a receiving stub which uses the opposite
- -- as a reply id. A message id helps to retrieve to which task is
- -- addressed a reply. When the environment task receives a message, the
- -- message id is extracted : a positive message id stands for a call, a
- -- negative message id stands for a reply. A null message id stands for
- -- an asynchronous request.
-
- subtype Request_Id_Type is Message_Id_Type range 1 .. Max_Of_Message_Id;
- -- When a message id is positive, it is a request
-
- type Message_Length_Per_Request is array (Request_Id_Type)
- of Ada.Streams.Stream_Element_Count;
-
- Header_Size : Ada.Streams.Stream_Element_Count :=
- Streams.Get_Integer_Initial_Size +
- Streams.Get_SEC_Initial_Size;
- -- Initial size needed for frequently used header streams
-
- Stream_Error : exception;
- -- Occurs when a read procedure is executed on an empty stream
- -- or when a write procedure is executed on a full stream
-
- Partition_RPC_Receiver : RPC_Receiver;
- -- Cache the RPC_Receiver passed by Establish_RPC_Receiver
-
- type Anonymous_Task_Node;
-
- type Anonymous_Task_Node_Access is access Anonymous_Task_Node;
- -- Types we need to construct a singly linked list of anonymous tasks
- -- This pool is maintained to avoid a task creation each time a RPC
- -- occurs - to be cont'd
-
- task type Anonymous_Task_Type (Self : Anonymous_Task_Node_Access) is
-
- entry Start
- (Message_Id : Message_Id_Type;
- Partition : Partition_ID;
- Params_Size : Ada.Streams.Stream_Element_Count;
- Result_Size : Ada.Streams.Stream_Element_Count;
- Protocol : Garlic.Protocol_Access);
- -- This entry provides an anonymous task a remote call to perform.
- -- This task calls for a Request id is provided to construct the
- -- reply id by using -Request. Partition is used to send the reply
- -- message. Params_Size is the size of the calling stub Params stream.
- -- Then Protocol (used by the environment task previously) allows
- -- extraction of the message following the header (The header is
- -- extracted by the environment task)
- -- Note: grammar in above is obscure??? needs cleanup
-
- end Anonymous_Task_Type;
-
- type Anonymous_Task_Access is access Anonymous_Task_Type;
-
- type Anonymous_Task_List is record
- Head : Anonymous_Task_Node_Access;
- Tail : Anonymous_Task_Node_Access;
- end record;
-
- type Anonymous_Task_Node is record
- Element : Anonymous_Task_Access;
- Next : Anonymous_Task_Node_Access;
- end record;
- -- Types we need to construct a singly linked list of anonymous tasks.
- -- This pool is maintained to avoid a task creation each time a RPC occurs.
-
- protected Garbage_Collector is
-
- procedure Allocate
- (Item : out Anonymous_Task_Node_Access);
- -- Anonymous task pool management : if there is an anonymous task
- -- left, use it. Otherwise, allocate a new one
-
- procedure Deallocate
- (Item : in out Anonymous_Task_Node_Access);
- -- Anonymous task pool management : queue this task in the pool
- -- of inactive anonymous tasks.
-
- private
-
- Anonymous_List : Anonymous_Task_Node_Access;
- -- The list root of inactive anonymous tasks
-
- end Garbage_Collector;
-
- task Dispatcher is
-
- entry New_Request (Request : out Request_Id_Type);
- -- To get a new request
-
- entry Wait_On (Request_Id_Type)
- (Length : out Ada.Streams.Stream_Element_Count);
- -- To block the calling stub when it waits for a reply
- -- When it is resumed, we provide the size of the reply
-
- entry Wake_Up
- (Request : Request_Id_Type;
- Length : Ada.Streams.Stream_Element_Count);
- -- To wake up the calling stub when the environment task has
- -- received a reply for this request
-
- end Dispatcher;
-
- task Environnement is
-
- entry Start;
- -- Receive no message until Partition_Receiver is set
- -- Establish_RPC_Receiver decides when the environment task
- -- is allowed to start
-
- end Environnement;
-
- protected Partition_Receiver is
-
- entry Is_Set;
- -- Blocks if the Partition_RPC_Receiver has not been set
-
- procedure Set;
- -- Done by Establish_RPC_Receiver when Partition_RPC_Receiver
- -- is known
-
- private
-
- Was_Set : Boolean := False;
- -- True when Partition_RPC_Receiver has been set
-
- end Partition_Receiver;
- -- Anonymous tasks have to wait for the Partition_RPC_Receiver
- -- to be established
-
- type Debug_Level is
- (D_Elaborate, -- About the elaboration of this package
- D_Communication, -- About calls to Send and Receive
- D_Debug, -- Verbose
- D_Exception); -- Exception handler
- -- Debugging levels
-
- package Debugging is new System.RPC.Net_Trace (Debug_Level, "RPC : ");
- -- Debugging package
-
- procedure D
- (Flag : Debug_Level; Info : String) renames Debugging.Debug;
- -- Shortcut
-
- ------------------------
- -- Partition_Receiver --
- ------------------------
-
- protected body Partition_Receiver is
-
- -------------------------------
- -- Partition_Receiver.Is_Set --
- -------------------------------
-
- entry Is_Set when Was_Set is
- begin
- null;
- end Is_Set;
-
- ----------------------------
- -- Partition_Receiver.Set --
- ----------------------------
-
- procedure Set is
- begin
- Was_Set := True;
- end Set;
-
- end Partition_Receiver;
-
- ---------------
- -- Head_Node --
- ---------------
-
- procedure Head_Node
- (Index : out Packet_Node_Access;
- Stream : Params_Stream_Type)
- is
- begin
- Index := Stream.Extra.Head;
-
- exception
- when others =>
- D (D_Exception, "exception in Head_Node");
- raise;
- end Head_Node;
-
- ---------------
- -- Tail_Node --
- ---------------
-
- procedure Tail_Node
- (Index : out Packet_Node_Access;
- Stream : Params_Stream_Type)
- is
- begin
- Index := Stream.Extra.Tail;
-
- exception
- when others =>
- D (D_Exception, "exception in Tail_Node");
- raise;
- end Tail_Node;
-
- ---------------
- -- Null_Node --
- ---------------
-
- function Null_Node (Index : Packet_Node_Access) return Boolean is
- begin
- return Index = null;
-
- exception
- when others =>
- D (D_Exception, "exception in Null_Node");
- raise;
- end Null_Node;
-
- ----------------------
- -- Delete_Head_Node --
- ----------------------
-
- procedure Delete_Head_Node (Stream : in out Params_Stream_Type) is
-
- procedure Free is
- new Unchecked_Deallocation
- (Packet_Node, Packet_Node_Access);
-
- Next_Node : Packet_Node_Access := Stream.Extra.Head.Next;
-
- begin
- -- Delete head node and free memory usage
-
- Free (Stream.Extra.Head);
- Stream.Extra.Head := Next_Node;
-
- -- If the extra storage is empty, update tail as well
-
- if Stream.Extra.Head = null then
- Stream.Extra.Tail := null;
- end if;
-
- exception
- when others =>
- D (D_Exception, "exception in Delete_Head_Node");
- raise;
- end Delete_Head_Node;
-
- ---------------
- -- Next_Node --
- ---------------
-
- procedure Next_Node (Node : in out Packet_Node_Access) is
- begin
- -- Node is set to the next node
- -- If not possible, Stream_Error is raised
-
- if Node = null then
- raise Stream_Error;
- else
- Node := Node.Next;
- end if;
-
- exception
- when others =>
- D (D_Exception, "exception in Next_Node");
- raise;
- end Next_Node;
-
- ---------------------
- -- Append_New_Node --
- ---------------------
-
- procedure Append_New_Node (Stream : in out Params_Stream_Type) is
- Index : Packet_Node_Access;
-
- begin
- -- Set Index to the end of the linked list
-
- Tail_Node (Index, Stream);
-
- if Null_Node (Index) then
-
- -- The list is empty : set head as well
-
- Stream.Extra.Head := new Packet_Node;
- Stream.Extra.Tail := Stream.Extra.Head;
-
- else
- -- The list is not empty : link new node with tail
-
- Stream.Extra.Tail.Next := new Packet_Node;
- Stream.Extra.Tail := Stream.Extra.Tail.Next;
-
- end if;
-
- exception
- when others =>
- D (D_Exception, "exception in Append_New_Node");
- raise;
- end Append_New_Node;
-
- ----------
- -- Read --
- ----------
-
- procedure Read
- (Stream : in out Params_Stream_Type;
- Item : out Ada.Streams.Stream_Element_Array;
- Last : out Ada.Streams.Stream_Element_Offset)
- renames System.RPC.Streams.Read;
-
- -----------
- -- Write --
- -----------
-
- procedure Write
- (Stream : in out Params_Stream_Type;
- Item : Ada.Streams.Stream_Element_Array)
- renames System.RPC.Streams.Write;
-
- -----------------------
- -- Garbage_Collector --
- -----------------------
-
- protected body Garbage_Collector is
-
- --------------------------------
- -- Garbage_Collector.Allocate --
- --------------------------------
-
- procedure Allocate (Item : out Anonymous_Task_Node_Access) is
- New_Anonymous_Task_Node : Anonymous_Task_Node_Access;
- Anonymous_Task : Anonymous_Task_Access;
-
- begin
- -- If the list is empty, allocate a new anonymous task
- -- Otherwise, reuse the first queued anonymous task
-
- if Anonymous_List = null then
-
- -- Create a new anonymous task
- -- Provide this new task with its id to allow it
- -- to enqueue itself into the free anonymous task list
- -- with the function Deallocate
-
- New_Anonymous_Task_Node := new Anonymous_Task_Node;
- Anonymous_Task :=
- new Anonymous_Task_Type (New_Anonymous_Task_Node);
- New_Anonymous_Task_Node.all := (Anonymous_Task, null);
-
- else
- -- Extract one task from the list
- -- Set the Next field to null to avoid possible bugs
-
- New_Anonymous_Task_Node := Anonymous_List;
- Anonymous_List := Anonymous_List.Next;
- New_Anonymous_Task_Node.Next := null;
-
- end if;
-
- -- Item is an out parameter
-
- Item := New_Anonymous_Task_Node;
-
- exception
- when others =>
- D (D_Exception, "exception in Allocate (Anonymous Task)");
- raise;
- end Allocate;
-
- ----------------------------------
- -- Garbage_Collector.Deallocate --
- ----------------------------------
-
- procedure Deallocate (Item : in out Anonymous_Task_Node_Access) is
- begin
- -- Enqueue the task in the free list
-
- Item.Next := Anonymous_List;
- Anonymous_List := Item;
-
- exception
- when others =>
- D (D_Exception, "exception in Deallocate (Anonymous Task)");
- raise;
- end Deallocate;
-
- end Garbage_Collector;
-
- ------------
- -- Do_RPC --
- ------------
-
- procedure Do_RPC
- (Partition : Partition_ID;
- Params : access Params_Stream_Type;
- Result : access Params_Stream_Type)
- is
- Protocol : Protocol_Access;
- Request : Request_Id_Type;
- Header : aliased Params_Stream_Type (Header_Size);
- R_Length : Ada.Streams.Stream_Element_Count;
-
- begin
- -- Parameters order :
- -- Opcode (provided and used by garlic)
- -- (1) Size (provided by s-rpc and used by garlic)
- -- (size of (2)+(3)+(4)+(5))
- -- (2) Request (provided by calling stub (resp receiving stub) and
- -- used by anonymous task (resp Do_RPC))
- -- *** ZERO IF APC ***
- -- (3) Res.len. (provided by calling stubs and used by anonymous task)
- -- *** ZERO IF APC ***
- -- (4) Receiver (provided by calling stubs and used by anonymous task)
- -- (5) Params (provided by calling stubs and used by anonymous task)
-
- -- The call is a remote call or a local call. A local call occurs
- -- when the pragma All_Calls_Remote has been specified. Do_RPC is
- -- called and the execution has to be performed in the PCS
-
- if Partition /= Garlic.Get_My_Partition_ID then
-
- -- Get a request id to be resumed when the reply arrives
-
- Dispatcher.New_Request (Request);
-
- -- Build header = request (2) + result.initial_size (3)
-
- D (D_Debug, "Do_RPC - Build header");
- Streams.Allocate (Header);
- Streams.Integer_Write_Attribute -- (2)
- (Header'Access, Request);
- System.RPC.Streams.SEC_Write_Attribute -- (3)
- (Header'Access, Result.Initial_Size);
-
- -- Get a protocol method to communicate with the remote partition
- -- and give the message size
-
- D (D_Communication,
- "Do_RPC - Lookup for protocol to talk to partition" &
- Partition_ID'Image (Partition));
- Garlic.Initiate_Send
- (Partition,
- Streams.Get_Stream_Size (Header'Access) +
- Streams.Get_Stream_Size (Params), -- (1)
- Protocol,
- Garlic.Remote_Call);
-
- -- Send the header by using the protocol method
-
- D (D_Communication, "Do_RPC - Send Header to partition" &
- Partition_ID'Image (Partition));
- Garlic.Send
- (Protocol.all,
- Partition,
- Header'Access); -- (2) + (3)
-
- -- The header is deallocated
-
- Streams.Deallocate (Header);
-
- -- Send Params from Do_RPC
-
- D (D_Communication, "Do_RPC - Send Params to partition" &
- Partition_ID'Image (Partition));
- Garlic.Send
- (Protocol.all,
- Partition,
- Params); -- (4) + (5)
-
- -- Let Garlic know we have nothing else to send
-
- Garlic.Complete_Send
- (Protocol.all,
- Partition);
- D (D_Debug, "Do_RPC - Suspend");
-
- -- Wait for a reply and get the reply message length
-
- Dispatcher.Wait_On (Request) (R_Length);
- D (D_Debug, "Do_RPC - Resume");
-
- declare
- New_Result : aliased Params_Stream_Type (R_Length);
- begin
- -- Adjust the Result stream size right now to be able to load
- -- the stream in one receive call. Create a temporary result
- -- that will be substituted to Do_RPC one
-
- Streams.Allocate (New_Result);
-
- -- Receive the reply message from receiving stub
-
- D (D_Communication, "Do_RPC - Receive Result from partition" &
- Partition_ID'Image (Partition));
- Garlic.Receive
- (Protocol.all,
- Partition,
- New_Result'Access);
-
- -- Let Garlic know we have nothing else to receive
-
- Garlic.Complete_Receive
- (Protocol.all,
- Partition);
-
- -- Update calling stub Result stream
-
- D (D_Debug, "Do_RPC - Reconstruct Result");
- Streams.Deallocate (Result.all);
- Result.Initial := New_Result.Initial;
- Streams.Dump ("|||", Result.all);
-
- end;
-
- else
- -- Do RPC locally and first wait for Partition_RPC_Receiver to be
- -- set
-
- Partition_Receiver.Is_Set;
- D (D_Debug, "Do_RPC - Locally");
- Partition_RPC_Receiver.all (Params, Result);
-
- end if;
-
- exception
- when others =>
- D (D_Exception, "exception in Do_RPC");
- raise;
- end Do_RPC;
-
- ------------
- -- Do_APC --
- ------------
-
- procedure Do_APC
- (Partition : Partition_ID;
- Params : access Params_Stream_Type)
- is
- Message_Id : Message_Id_Type := 0;
- Protocol : Protocol_Access;
- Header : aliased Params_Stream_Type (Header_Size);
-
- begin
- -- For more information, see above
- -- Request = 0 as we are not waiting for a reply message
- -- Result length = 0 as we don't expect a result at all
-
- if Partition /= Garlic.Get_My_Partition_ID then
-
- -- Build header = request (2) + result.initial_size (3)
- -- As we have an APC, the request id is null to indicate
- -- to the receiving stub that we do not expect a reply
- -- This comes from 0 = -0
-
- D (D_Debug, "Do_APC - Build Header");
- Streams.Allocate (Header);
- Streams.Integer_Write_Attribute
- (Header'Access, Integer (Message_Id));
- Streams.SEC_Write_Attribute
- (Header'Access, 0);
-
- -- Get a protocol method to communicate with the remote partition
- -- and give the message size
-
- D (D_Communication,
- "Do_APC - Lookup for protocol to talk to partition" &
- Partition_ID'Image (Partition));
- Garlic.Initiate_Send
- (Partition,
- Streams.Get_Stream_Size (Header'Access) +
- Streams.Get_Stream_Size (Params),
- Protocol,
- Garlic.Remote_Call);
-
- -- Send the header by using the protocol method
-
- D (D_Communication, "Do_APC - Send Header to partition" &
- Partition_ID'Image (Partition));
- Garlic.Send
- (Protocol.all,
- Partition,
- Header'Access);
-
- -- The header is deallocated
-
- Streams.Deallocate (Header);
-
- -- Send Params from Do_APC
-
- D (D_Communication, "Do_APC - Send Params to partition" &
- Partition_ID'Image (Partition));
- Garlic.Send
- (Protocol.all,
- Partition,
- Params);
-
- -- Let Garlic know we have nothing else to send
-
- Garlic.Complete_Send
- (Protocol.all,
- Partition);
- else
-
- declare
- Result : aliased Params_Stream_Type (0);
- begin
- -- Result is here a dummy parameter
- -- No reason to deallocate as it is not allocated at all
-
- Partition_Receiver.Is_Set;
- D (D_Debug, "Do_APC - Locally");
- Partition_RPC_Receiver.all (Params, Result'Access);
-
- end;
-
- end if;
-
- exception
- when others =>
- D (D_Exception, "exception in Do_APC");
- raise;
- end Do_APC;
-
- ----------------------------
- -- Establish_RPC_Receiver --
- ----------------------------
-
- procedure Establish_RPC_Receiver
- (Partition : Partition_ID;
- Receiver : RPC_Receiver)
- is
- begin
- -- Set Partition_RPC_Receiver and allow RPC mechanism
-
- Partition_RPC_Receiver := Receiver;
- Partition_Receiver.Set;
- D (D_Elaborate, "Partition_Receiver is set");
-
- exception
- when others =>
- D (D_Exception, "exception in Establish_RPC_Receiver");
- raise;
- end Establish_RPC_Receiver;
-
- ----------------
- -- Dispatcher --
- ----------------
-
- task body Dispatcher is
- Last_Request : Request_Id_Type := Request_Id_Type'First;
- Current_Rqst : Request_Id_Type := Request_Id_Type'First;
- Current_Size : Ada.Streams.Stream_Element_Count;
-
- begin
- loop
- -- Three services:
-
- -- New_Request to get an entry in Dispatcher table
-
- -- Wait_On for Do_RPC calls
-
- -- Wake_Up called by environment task when a Do_RPC receives
- -- the result of its remote call
-
- select
- accept New_Request (Request : out Request_Id_Type) do
- Request := Last_Request;
-
- -- << TODO >>
- -- ??? Availability check
-
- if Last_Request = Request_Id_Type'Last then
- Last_Request := Request_Id_Type'First;
- else
- Last_Request := Last_Request + 1;
- end if;
-
- end New_Request;
-
- or
- accept Wake_Up
- (Request : Request_Id_Type;
- Length : Ada.Streams.Stream_Element_Count)
- do
- -- The environment reads the header and has been notified
- -- of the reply id and the size of the result message
-
- Current_Rqst := Request;
- Current_Size := Length;
-
- end Wake_Up;
-
- -- << TODO >>
- -- ??? Must be select with delay for aborted tasks
-
- select
-
- accept Wait_On (Current_Rqst)
- (Length : out Ada.Streams.Stream_Element_Count)
- do
- Length := Current_Size;
- end Wait_On;
-
- or
- -- To free the Dispatcher when a task is aborted
-
- delay 1.0;
-
- end select;
-
- or
- terminate;
- end select;
-
- end loop;
-
- exception
- when others =>
- D (D_Exception, "exception in Dispatcher body");
- raise;
- end Dispatcher;
-
- -------------------------
- -- Anonymous_Task_Type --
- -------------------------
-
- task body Anonymous_Task_Type is
- Whoami : Anonymous_Task_Node_Access := Self;
- C_Message_Id : Message_Id_Type; -- Current Message Id
- C_Partition : Partition_ID; -- Current Partition
- Params_S : Ada.Streams.Stream_Element_Count; -- Params message size
- Result_S : Ada.Streams.Stream_Element_Count; -- Result message size
- C_Protocol : Protocol_Access; -- Current Protocol
-
- begin
- loop
- -- Get a new RPC to execute
-
- select
- accept Start
- (Message_Id : Message_Id_Type;
- Partition : Partition_ID;
- Params_Size : Ada.Streams.Stream_Element_Count;
- Result_Size : Ada.Streams.Stream_Element_Count;
- Protocol : Protocol_Access)
- do
- C_Message_Id := Message_Id;
- C_Partition := Partition;
- Params_S := Params_Size;
- Result_S := Result_Size;
- C_Protocol := Protocol;
- end Start;
- or
- terminate;
- end select;
-
- declare
- Params : aliased Params_Stream_Type (Params_S);
- Result : aliased Params_Stream_Type (Result_S);
- Header : aliased Params_Stream_Type (Header_Size);
-
- begin
- -- We reconstruct all the client context : Params and Result
- -- with the SAME size, then we receive Params from calling stub
-
- D (D_Communication,
- "Anonymous Task - Receive Params from partition" &
- Partition_ID'Image (C_Partition));
- Garlic.Receive
- (C_Protocol.all,
- C_Partition,
- Params'Access);
-
- -- Let Garlic know we don't receive anymore
-
- Garlic.Complete_Receive
- (C_Protocol.all,
- C_Partition);
-
- -- Check that Partition_RPC_Receiver has been set
-
- Partition_Receiver.Is_Set;
-
- -- Do it locally
-
- D (D_Debug,
- "Anonymous Task - Perform Partition_RPC_Receiver for request" &
- Message_Id_Type'Image (C_Message_Id));
- Partition_RPC_Receiver (Params'Access, Result'Access);
-
- -- If this was a RPC we send the result back
- -- Otherwise, do nothing else than deallocation
-
- if C_Message_Id /= 0 then
-
- -- Build Header = -C_Message_Id + Result Size
- -- Provide the request id to the env task of the calling
- -- stub partition We get the real result stream size : the
- -- calling stub (in Do_RPC) updates its size to this one
-
- D (D_Debug, "Anonymous Task - Build Header");
- Streams.Allocate (Header);
- Streams.Integer_Write_Attribute
- (Header'Access, Integer (-C_Message_Id));
- Streams.SEC_Write_Attribute
- (Header'Access,
- Streams.Get_Stream_Size (Result'Access));
-
- -- Get a protocol method to communicate with the remote
- -- partition and give the message size
-
- D (D_Communication,
- "Anonymous Task - Lookup for protocol talk to partition" &
- Partition_ID'Image (C_Partition));
- Garlic.Initiate_Send
- (C_Partition,
- Streams.Get_Stream_Size (Header'Access) +
- Streams.Get_Stream_Size (Result'Access),
- C_Protocol,
- Garlic.Remote_Call);
-
- -- Send the header by using the protocol method
-
- D (D_Communication,
- "Anonymous Task - Send Header to partition" &
- Partition_ID'Image (C_Partition));
- Garlic.Send
- (C_Protocol.all,
- C_Partition,
- Header'Access);
-
- -- Send Result toDo_RPC
-
- D (D_Communication,
- "Anonymous Task - Send Result to partition" &
- Partition_ID'Image (C_Partition));
- Garlic.Send
- (C_Protocol.all,
- C_Partition,
- Result'Access);
-
- -- Let Garlic know we don't send anymore
-
- Garlic.Complete_Send
- (C_Protocol.all,
- C_Partition);
- Streams.Deallocate (Header);
- end if;
-
- Streams.Deallocate (Params);
- Streams.Deallocate (Result);
- end;
-
- -- Enqueue into the anonymous task free list : become inactive
-
- Garbage_Collector.Deallocate (Whoami);
-
- end loop;
-
- exception
- when others =>
- D (D_Exception, "exception in Anonymous_Task_Type body");
- raise;
- end Anonymous_Task_Type;
-
- -----------------
- -- Environment --
- -----------------
-
- task body Environnement is
- Partition : Partition_ID;
- Message_Size : Ada.Streams.Stream_Element_Count;
- Result_Size : Ada.Streams.Stream_Element_Count;
- Message_Id : Message_Id_Type;
- Header : aliased Params_Stream_Type (Header_Size);
- Protocol : Protocol_Access;
- Anonymous : Anonymous_Task_Node_Access;
-
- begin
- -- Wait the Partition_RPC_Receiver to be set
-
- accept Start;
- D (D_Elaborate, "Environment task elaborated");
-
- loop
- -- We receive first a fixed size message : the header
- -- Header = Message Id + Message Size
-
- Streams.Allocate (Header);
-
- -- Garlic provides the size of the received message and the
- -- protocol to use to communicate with the calling partition
-
- Garlic.Initiate_Receive
- (Partition,
- Message_Size,
- Protocol,
- Garlic.Remote_Call);
- D (D_Communication,
- "Environment task - Receive protocol to talk to active partition" &
- Partition_ID'Image (Partition));
-
- -- Extract the header to route the message either to
- -- an anonymous task (Message Id > 0 <=> Request Id)
- -- or to a waiting task (Message Id < 0 <=> Reply Id)
-
- D (D_Communication,
- "Environment task - Receive Header from partition" &
- Partition_ID'Image (Partition));
- Garlic.Receive
- (Protocol.all,
- Partition,
- Header'Access);
-
- -- Evaluate the remaining size of the message
-
- Message_Size := Message_Size -
- Streams.Get_Stream_Size (Header'Access);
-
- -- Extract from header : message id and message size
-
- Streams.Integer_Read_Attribute (Header'Access, Message_Id);
- Streams.SEC_Read_Attribute (Header'Access, Result_Size);
-
- if Streams.Get_Stream_Size (Header'Access) /= 0 then
-
- -- If there are stream elements left in the header ???
-
- D (D_Exception, "Header is not empty");
- raise Program_Error;
-
- end if;
-
- if Message_Id < 0 then
-
- -- The message was sent by a receiving stub : wake up the
- -- calling task - We have a reply there
-
- D (D_Debug, "Environment Task - Receive Reply from partition" &
- Partition_ID'Image (Partition));
- Dispatcher.Wake_Up (-Message_Id, Result_Size);
-
- else
- -- The message was send by a calling stub : get an anonymous
- -- task to perform the job
-
- D (D_Debug, "Environment Task - Receive Request from partition" &
- Partition_ID'Image (Partition));
- Garbage_Collector.Allocate (Anonymous);
-
- -- We subtracted the size of the header from the size of the
- -- global message in order to provide immediately Params size
-
- Anonymous.Element.Start
- (Message_Id,
- Partition,
- Message_Size,
- Result_Size,
- Protocol);
-
- end if;
-
- -- Deallocate header : unnecessary - WARNING
-
- Streams.Deallocate (Header);
-
- end loop;
-
- exception
- when others =>
- D (D_Exception, "exception in Environment");
- raise;
- end Environnement;
-
-begin
- -- Set debugging information
-
- Debugging.Set_Environment_Variable ("RPC");
- Debugging.Set_Debugging_Name ("D", D_Debug);
- Debugging.Set_Debugging_Name ("E", D_Exception);
- Debugging.Set_Debugging_Name ("C", D_Communication);
- Debugging.Set_Debugging_Name ("Z", D_Elaborate);
- D (D_Elaborate, "To be elaborated");
-
- -- When this body is elaborated we should ensure that RCI name server
- -- has been already elaborated : this means that Establish_RPC_Receiver
- -- has already been called and that Partition_RPC_Receiver is set
-
- Environnement.Start;
- D (D_Elaborate, "ELABORATED");
-
-end System.RPC;
projects / gcc.git / commitdiff