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