1052 lines
32 KiB
Ada
1052 lines
32 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- 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;
|