Daily bump.
[official-gcc.git] / gcc / ada / 9drpc.adb
blob75acad70dedaee0698cc16b5fc4de21a00d9f179
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S Y S T E M . R P C --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2006 Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
28 -- --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 -- --
32 ------------------------------------------------------------------------------
34 -- Version for ???
36 with Unchecked_Deallocation;
37 with Ada.Streams;
39 with System.RPC.Net_Trace;
40 with System.RPC.Garlic;
41 with System.RPC.Streams;
42 pragma Elaborate (System.RPC.Garlic);
44 package body System.RPC is
46 -- ??? general note: the debugging calls are very heavy, especially
47 -- those that create exception handlers in every procedure. Do we
48 -- really still need all this stuff?
50 use type Ada.Streams.Stream_Element_Count;
51 use type Ada.Streams.Stream_Element_Offset;
53 use type Garlic.Protocol_Access;
54 use type Garlic.Lock_Method;
56 Max_Of_Message_Id : constant := 127;
58 subtype Message_Id_Type is
59 Integer range -Max_Of_Message_Id .. Max_Of_Message_Id;
60 -- A message id is either a request id or reply id. A message id is
61 -- provided with a message to a receiving stub which uses the opposite
62 -- as a reply id. A message id helps to retrieve to which task is
63 -- addressed a reply. When the environment task receives a message, the
64 -- message id is extracted : a positive message id stands for a call, a
65 -- negative message id stands for a reply. A null message id stands for
66 -- an asynchronous request.
68 subtype Request_Id_Type is Message_Id_Type range 1 .. Max_Of_Message_Id;
69 -- When a message id is positive, it is a request
71 type Message_Length_Per_Request is array (Request_Id_Type)
72 of Ada.Streams.Stream_Element_Count;
74 Header_Size : Ada.Streams.Stream_Element_Count :=
75 Streams.Get_Integer_Initial_Size +
76 Streams.Get_SEC_Initial_Size;
77 -- Initial size needed for frequently used header streams
79 Stream_Error : exception;
80 -- Occurs when a read procedure is executed on an empty stream
81 -- or when a write procedure is executed on a full stream
83 Partition_RPC_Receiver : RPC_Receiver;
84 -- Cache the RPC_Recevier passed by Establish_RPC_Receiver
86 type Anonymous_Task_Node;
88 type Anonymous_Task_Node_Access is access Anonymous_Task_Node;
89 -- Types we need to construct a singly linked list of anonymous tasks
90 -- This pool is maintained to avoid a task creation each time a RPC
91 -- occurs - to be cont'd
93 task type Anonymous_Task_Type (Self : Anonymous_Task_Node_Access) is
95 entry Start
96 (Message_Id : Message_Id_Type;
97 Partition : Partition_ID;
98 Params_Size : Ada.Streams.Stream_Element_Count;
99 Result_Size : Ada.Streams.Stream_Element_Count;
100 Protocol : Garlic.Protocol_Access);
101 -- This entry provides an anonymous task a remote call to perform.
102 -- This task calls for a Request id is provided to construct the
103 -- reply id by using -Request. Partition is used to send the reply
104 -- message. Params_Size is the size of the calling stub Params stream.
105 -- Then Protocol (used by the environment task previously) allows
106 -- extraction of the message following the header (The header is
107 -- extracted by the environment task)
108 -- Note: grammar in above is obscure??? needs cleanup
110 end Anonymous_Task_Type;
112 type Anonymous_Task_Access is access Anonymous_Task_Type;
114 type Anonymous_Task_List is record
115 Head : Anonymous_Task_Node_Access;
116 Tail : Anonymous_Task_Node_Access;
117 end record;
119 type Anonymous_Task_Node is record
120 Element : Anonymous_Task_Access;
121 Next : Anonymous_Task_Node_Access;
122 end record;
123 -- Types we need to construct a singly linked list of anonymous tasks.
124 -- This pool is maintained to avoid a task creation each time a RPC occurs.
126 protected Garbage_Collector is
128 procedure Allocate
129 (Item : out Anonymous_Task_Node_Access);
130 -- Anonymous task pool management : if there is an anonymous task
131 -- left, use it. Otherwise, allocate a new one
133 procedure Deallocate
134 (Item : in out Anonymous_Task_Node_Access);
135 -- Anonymous task pool management : queue this task in the pool
136 -- of inactive anonymous tasks.
138 private
140 Anonymous_List : Anonymous_Task_Node_Access;
141 -- The list root of inactive anonymous tasks
143 end Garbage_Collector;
145 task Dispatcher is
147 entry New_Request (Request : out Request_Id_Type);
148 -- To get a new request
150 entry Wait_On (Request_Id_Type)
151 (Length : out Ada.Streams.Stream_Element_Count);
152 -- To block the calling stub when it waits for a reply
153 -- When it is resumed, we provide the size of the reply
155 entry Wake_Up
156 (Request : Request_Id_Type;
157 Length : Ada.Streams.Stream_Element_Count);
158 -- To wake up the calling stub when the environnement task has
159 -- received a reply for this request
161 end Dispatcher;
163 task Environnement is
165 entry Start;
166 -- Receive no message until Partition_Receiver is set
167 -- Establish_RPC_Receiver decides when the environment task
168 -- is allowed to start
170 end Environnement;
172 protected Partition_Receiver is
174 entry Is_Set;
175 -- Blocks if the Partition_RPC_Receiver has not been set
177 procedure Set;
178 -- Done by Establish_RPC_Receiver when Partition_RPC_Receiver
179 -- is known
181 private
183 Was_Set : Boolean := False;
184 -- True when Partition_RPC_Receiver has been set
186 end Partition_Receiver;
187 -- Anonymous tasks have to wait for the Partition_RPC_Receiver
188 -- to be established
190 type Debug_Level is
191 (D_Elaborate, -- About the elaboration of this package
192 D_Communication, -- About calls to Send and Receive
193 D_Debug, -- Verbose
194 D_Exception); -- Exception handler
195 -- Debugging levels
197 package Debugging is new System.RPC.Net_Trace (Debug_Level, "RPC : ");
198 -- Debugging package
200 procedure D
201 (Flag : Debug_Level; Info : String) renames Debugging.Debug;
202 -- Shortcut
204 ------------------------
205 -- Partition_Receiver --
206 ------------------------
208 protected body Partition_Receiver is
210 -------------------------------
211 -- Partition_Receiver.Is_Set --
212 -------------------------------
214 entry Is_Set when Was_Set is
215 begin
216 null;
217 end Is_Set;
219 ----------------------------
220 -- Partition_Receiver.Set --
221 ----------------------------
223 procedure Set is
224 begin
225 Was_Set := True;
226 end Set;
228 end Partition_Receiver;
230 ---------------
231 -- Head_Node --
232 ---------------
234 procedure Head_Node
235 (Index : out Packet_Node_Access;
236 Stream : Params_Stream_Type)
238 begin
239 Index := Stream.Extra.Head;
241 exception
242 when others =>
243 D (D_Exception, "exception in Head_Node");
244 raise;
245 end Head_Node;
247 ---------------
248 -- Tail_Node --
249 ---------------
251 procedure Tail_Node
252 (Index : out Packet_Node_Access;
253 Stream : Params_Stream_Type)
255 begin
256 Index := Stream.Extra.Tail;
258 exception
259 when others =>
260 D (D_Exception, "exception in Tail_Node");
261 raise;
262 end Tail_Node;
264 ---------------
265 -- Null_Node --
266 ---------------
268 function Null_Node (Index : Packet_Node_Access) return Boolean is
269 begin
270 return Index = null;
272 exception
273 when others =>
274 D (D_Exception, "exception in Null_Node");
275 raise;
276 end Null_Node;
278 ----------------------
279 -- Delete_Head_Node --
280 ----------------------
282 procedure Delete_Head_Node (Stream : in out Params_Stream_Type) is
284 procedure Free is
285 new Unchecked_Deallocation
286 (Packet_Node, Packet_Node_Access);
288 Next_Node : Packet_Node_Access := Stream.Extra.Head.Next;
290 begin
291 -- Delete head node and free memory usage
293 Free (Stream.Extra.Head);
294 Stream.Extra.Head := Next_Node;
296 -- If the extra storage is empty, update tail as well
298 if Stream.Extra.Head = null then
299 Stream.Extra.Tail := null;
300 end if;
302 exception
303 when others =>
304 D (D_Exception, "exception in Delete_Head_Node");
305 raise;
306 end Delete_Head_Node;
308 ---------------
309 -- Next_Node --
310 ---------------
312 procedure Next_Node (Node : in out Packet_Node_Access) is
313 begin
314 -- Node is set to the next node
315 -- If not possible, Stream_Error is raised
317 if Node = null then
318 raise Stream_Error;
319 else
320 Node := Node.Next;
321 end if;
323 exception
324 when others =>
325 D (D_Exception, "exception in Next_Node");
326 raise;
327 end Next_Node;
329 ---------------------
330 -- Append_New_Node --
331 ---------------------
333 procedure Append_New_Node (Stream : in out Params_Stream_Type) is
334 Index : Packet_Node_Access;
336 begin
337 -- Set Index to the end of the linked list
339 Tail_Node (Index, Stream);
341 if Null_Node (Index) then
343 -- The list is empty : set head as well
345 Stream.Extra.Head := new Packet_Node;
346 Stream.Extra.Tail := Stream.Extra.Head;
348 else
349 -- The list is not empty : link new node with tail
351 Stream.Extra.Tail.Next := new Packet_Node;
352 Stream.Extra.Tail := Stream.Extra.Tail.Next;
354 end if;
356 exception
357 when others =>
358 D (D_Exception, "exception in Append_New_Node");
359 raise;
360 end Append_New_Node;
362 ----------
363 -- Read --
364 ----------
366 procedure Read
367 (Stream : in out Params_Stream_Type;
368 Item : out Ada.Streams.Stream_Element_Array;
369 Last : out Ada.Streams.Stream_Element_Offset)
370 renames System.RPC.Streams.Read;
372 -----------
373 -- Write --
374 -----------
376 procedure Write
377 (Stream : in out Params_Stream_Type;
378 Item : Ada.Streams.Stream_Element_Array)
379 renames System.RPC.Streams.Write;
381 -----------------------
382 -- Garbage_Collector --
383 -----------------------
385 protected body Garbage_Collector is
387 --------------------------------
388 -- Garbage_Collector.Allocate --
389 --------------------------------
391 procedure Allocate (Item : out Anonymous_Task_Node_Access) is
392 New_Anonymous_Task_Node : Anonymous_Task_Node_Access;
393 Anonymous_Task : Anonymous_Task_Access;
395 begin
396 -- If the list is empty, allocate a new anonymous task
397 -- Otherwise, reuse the first queued anonymous task
399 if Anonymous_List = null then
401 -- Create a new anonymous task
402 -- Provide this new task with its id to allow it
403 -- to enqueue itself into the free anonymous task list
404 -- with the function Deallocate
406 New_Anonymous_Task_Node := new Anonymous_Task_Node;
407 Anonymous_Task :=
408 new Anonymous_Task_Type (New_Anonymous_Task_Node);
409 New_Anonymous_Task_Node.all := (Anonymous_Task, null);
411 else
412 -- Extract one task from the list
413 -- Set the Next field to null to avoid possible bugs
415 New_Anonymous_Task_Node := Anonymous_List;
416 Anonymous_List := Anonymous_List.Next;
417 New_Anonymous_Task_Node.Next := null;
419 end if;
421 -- Item is an out parameter
423 Item := New_Anonymous_Task_Node;
425 exception
426 when others =>
427 D (D_Exception, "exception in Allocate (Anonymous Task)");
428 raise;
429 end Allocate;
431 ----------------------------------
432 -- Garbage_Collector.Deallocate --
433 ----------------------------------
435 procedure Deallocate (Item : in out Anonymous_Task_Node_Access) is
436 begin
437 -- Enqueue the task in the free list
439 Item.Next := Anonymous_List;
440 Anonymous_List := Item;
442 exception
443 when others =>
444 D (D_Exception, "exception in Deallocate (Anonymous Task)");
445 raise;
446 end Deallocate;
448 end Garbage_Collector;
450 ------------
451 -- Do_RPC --
452 ------------
454 procedure Do_RPC
455 (Partition : Partition_ID;
456 Params : access Params_Stream_Type;
457 Result : access Params_Stream_Type)
459 Protocol : Protocol_Access;
460 Request : Request_Id_Type;
461 Header : aliased Params_Stream_Type (Header_Size);
462 R_Length : Ada.Streams.Stream_Element_Count;
464 begin
465 -- Parameters order :
466 -- Opcode (provided and used by garlic)
467 -- (1) Size (provided by s-rpc and used by garlic)
468 -- (size of (2)+(3)+(4)+(5))
469 -- (2) Request (provided by calling stub (resp receiving stub) and
470 -- used by anonymous task (resp Do_RPC))
471 -- *** ZERO IF APC ***
472 -- (3) Res.len. (provided by calling stubs and used by anonymous task)
473 -- *** ZERO IF APC ***
474 -- (4) Receiver (provided by calling stubs and used by anonymous task)
475 -- (5) Params (provided by calling stubs and used by anonymous task)
477 -- The call is a remote call or a local call. A local call occurs
478 -- when the pragma All_Calls_Remote has been specified. Do_RPC is
479 -- called and the execution has to be performed in the PCS
481 if Partition /= Garlic.Get_My_Partition_ID then
483 -- Get a request id to be resumed when the reply arrives
485 Dispatcher.New_Request (Request);
487 -- Build header = request (2) + result.initial_size (3)
489 D (D_Debug, "Do_RPC - Build header");
490 Streams.Allocate (Header);
491 Streams.Integer_Write_Attribute -- (2)
492 (Header'Access, Request);
493 System.RPC.Streams.SEC_Write_Attribute -- (3)
494 (Header'Access, Result.Initial_Size);
496 -- Get a protocol method to communicate with the remote partition
497 -- and give the message size
499 D (D_Communication,
500 "Do_RPC - Lookup for protocol to talk to partition" &
501 Partition_ID'Image (Partition));
502 Garlic.Initiate_Send
503 (Partition,
504 Streams.Get_Stream_Size (Header'Access) +
505 Streams.Get_Stream_Size (Params), -- (1)
506 Protocol,
507 Garlic.Remote_Call);
509 -- Send the header by using the protocol method
511 D (D_Communication, "Do_RPC - Send Header to partition" &
512 Partition_ID'Image (Partition));
513 Garlic.Send
514 (Protocol.all,
515 Partition,
516 Header'Access); -- (2) + (3)
518 -- The header is deallocated
520 Streams.Deallocate (Header);
522 -- Send Params from Do_RPC
524 D (D_Communication, "Do_RPC - Send Params to partition" &
525 Partition_ID'Image (Partition));
526 Garlic.Send
527 (Protocol.all,
528 Partition,
529 Params); -- (4) + (5)
531 -- Let Garlic know we have nothing else to send
533 Garlic.Complete_Send
534 (Protocol.all,
535 Partition);
536 D (D_Debug, "Do_RPC - Suspend");
538 -- Wait for a reply and get the reply message length
540 Dispatcher.Wait_On (Request) (R_Length);
541 D (D_Debug, "Do_RPC - Resume");
543 declare
544 New_Result : aliased Params_Stream_Type (R_Length);
545 begin
546 -- Adjust the Result stream size right now to be able to load
547 -- the stream in one receive call. Create a temporary resutl
548 -- that will be substituted to Do_RPC one
550 Streams.Allocate (New_Result);
552 -- Receive the reply message from receiving stub
554 D (D_Communication, "Do_RPC - Receive Result from partition" &
555 Partition_ID'Image (Partition));
556 Garlic.Receive
557 (Protocol.all,
558 Partition,
559 New_Result'Access);
561 -- Let Garlic know we have nothing else to receive
563 Garlic.Complete_Receive
564 (Protocol.all,
565 Partition);
567 -- Update calling stub Result stream
569 D (D_Debug, "Do_RPC - Reconstruct Result");
570 Streams.Deallocate (Result.all);
571 Result.Initial := New_Result.Initial;
572 Streams.Dump ("|||", Result.all);
574 end;
576 else
577 -- Do RPC locally and first wait for Partition_RPC_Receiver to be
578 -- set
580 Partition_Receiver.Is_Set;
581 D (D_Debug, "Do_RPC - Locally");
582 Partition_RPC_Receiver.all (Params, Result);
584 end if;
586 exception
587 when others =>
588 D (D_Exception, "exception in Do_RPC");
589 raise;
590 end Do_RPC;
592 ------------
593 -- Do_APC --
594 ------------
596 procedure Do_APC
597 (Partition : Partition_ID;
598 Params : access Params_Stream_Type)
600 Message_Id : Message_Id_Type := 0;
601 Protocol : Protocol_Access;
602 Header : aliased Params_Stream_Type (Header_Size);
604 begin
605 -- For more informations, see above
606 -- Request = 0 as we are not waiting for a reply message
607 -- Result length = 0 as we don't expect a result at all
609 if Partition /= Garlic.Get_My_Partition_ID then
611 -- Build header = request (2) + result.initial_size (3)
612 -- As we have an APC, the request id is null to indicate
613 -- to the receiving stub that we do not expect a reply
614 -- This comes from 0 = -0
616 D (D_Debug, "Do_APC - Build Header");
617 Streams.Allocate (Header);
618 Streams.Integer_Write_Attribute
619 (Header'Access, Integer (Message_Id));
620 Streams.SEC_Write_Attribute
621 (Header'Access, 0);
623 -- Get a protocol method to communicate with the remote partition
624 -- and give the message size
626 D (D_Communication,
627 "Do_APC - Lookup for protocol to talk to partition" &
628 Partition_ID'Image (Partition));
629 Garlic.Initiate_Send
630 (Partition,
631 Streams.Get_Stream_Size (Header'Access) +
632 Streams.Get_Stream_Size (Params),
633 Protocol,
634 Garlic.Remote_Call);
636 -- Send the header by using the protocol method
638 D (D_Communication, "Do_APC - Send Header to partition" &
639 Partition_ID'Image (Partition));
640 Garlic.Send
641 (Protocol.all,
642 Partition,
643 Header'Access);
645 -- The header is deallocated
647 Streams.Deallocate (Header);
649 -- Send Params from Do_APC
651 D (D_Communication, "Do_APC - Send Params to partition" &
652 Partition_ID'Image (Partition));
653 Garlic.Send
654 (Protocol.all,
655 Partition,
656 Params);
658 -- Let Garlic know we have nothing else to send
660 Garlic.Complete_Send
661 (Protocol.all,
662 Partition);
663 else
665 declare
666 Result : aliased Params_Stream_Type (0);
667 begin
668 -- Result is here a dummy parameter
669 -- No reason to deallocate as it is not allocated at all
671 Partition_Receiver.Is_Set;
672 D (D_Debug, "Do_APC - Locally");
673 Partition_RPC_Receiver.all (Params, Result'Access);
675 end;
677 end if;
679 exception
680 when others =>
681 D (D_Exception, "exception in Do_APC");
682 raise;
683 end Do_APC;
685 ----------------------------
686 -- Establish_RPC_Receiver --
687 ----------------------------
689 procedure Establish_RPC_Receiver
690 (Partition : Partition_ID;
691 Receiver : RPC_Receiver)
693 begin
694 -- Set Partition_RPC_Receiver and allow RPC mechanism
696 Partition_RPC_Receiver := Receiver;
697 Partition_Receiver.Set;
698 D (D_Elaborate, "Partition_Receiver is set");
700 exception
701 when others =>
702 D (D_Exception, "exception in Establish_RPC_Receiver");
703 raise;
704 end Establish_RPC_Receiver;
706 ----------------
707 -- Dispatcher --
708 ----------------
710 task body Dispatcher is
711 Last_Request : Request_Id_Type := Request_Id_Type'First;
712 Current_Rqst : Request_Id_Type := Request_Id_Type'First;
713 Current_Size : Ada.Streams.Stream_Element_Count;
715 begin
716 loop
717 -- Three services:
719 -- New_Request to get an entry in Dispatcher table
721 -- Wait_On for Do_RPC calls
723 -- Wake_Up called by environment task when a Do_RPC receives
724 -- the result of its remote call
726 select
727 accept New_Request (Request : out Request_Id_Type) do
728 Request := Last_Request;
730 -- << TODO >>
731 -- ??? Avaibility check
733 if Last_Request = Request_Id_Type'Last then
734 Last_Request := Request_Id_Type'First;
735 else
736 Last_Request := Last_Request + 1;
737 end if;
739 end New_Request;
742 accept Wake_Up
743 (Request : Request_Id_Type;
744 Length : Ada.Streams.Stream_Element_Count)
746 -- The environment reads the header and has been notified
747 -- of the reply id and the size of the result message
749 Current_Rqst := Request;
750 Current_Size := Length;
752 end Wake_Up;
754 -- << TODO >>
755 -- ??? Must be select with delay for aborted tasks
757 select
759 accept Wait_On (Current_Rqst)
760 (Length : out Ada.Streams.Stream_Element_Count)
762 Length := Current_Size;
763 end Wait_On;
766 -- To free the Dispatcher when a task is aborted
768 delay 1.0;
770 end select;
773 terminate;
774 end select;
776 end loop;
778 exception
779 when others =>
780 D (D_Exception, "exception in Dispatcher body");
781 raise;
782 end Dispatcher;
784 -------------------------
785 -- Anonymous_Task_Type --
786 -------------------------
788 task body Anonymous_Task_Type is
789 Whoami : Anonymous_Task_Node_Access := Self;
790 C_Message_Id : Message_Id_Type; -- Current Message Id
791 C_Partition : Partition_ID; -- Current Partition
792 Params_S : Ada.Streams.Stream_Element_Count; -- Params message size
793 Result_S : Ada.Streams.Stream_Element_Count; -- Result message size
794 C_Protocol : Protocol_Access; -- Current Protocol
796 begin
797 loop
798 -- Get a new RPC to execute
800 select
801 accept Start
802 (Message_Id : Message_Id_Type;
803 Partition : Partition_ID;
804 Params_Size : Ada.Streams.Stream_Element_Count;
805 Result_Size : Ada.Streams.Stream_Element_Count;
806 Protocol : Protocol_Access)
808 C_Message_Id := Message_Id;
809 C_Partition := Partition;
810 Params_S := Params_Size;
811 Result_S := Result_Size;
812 C_Protocol := Protocol;
813 end Start;
815 terminate;
816 end select;
818 declare
819 Params : aliased Params_Stream_Type (Params_S);
820 Result : aliased Params_Stream_Type (Result_S);
821 Header : aliased Params_Stream_Type (Header_Size);
823 begin
824 -- We reconstruct all the client context : Params and Result
825 -- with the SAME size, then we receive Params from calling stub
827 D (D_Communication,
828 "Anonymous Task - Receive Params from partition" &
829 Partition_ID'Image (C_Partition));
830 Garlic.Receive
831 (C_Protocol.all,
832 C_Partition,
833 Params'Access);
835 -- Let Garlic know we don't receive anymore
837 Garlic.Complete_Receive
838 (C_Protocol.all,
839 C_Partition);
841 -- Check that Partition_RPC_Receiver has been set
843 Partition_Receiver.Is_Set;
845 -- Do it locally
847 D (D_Debug,
848 "Anonymous Task - Perform Partition_RPC_Receiver for request" &
849 Message_Id_Type'Image (C_Message_Id));
850 Partition_RPC_Receiver (Params'Access, Result'Access);
852 -- If this was a RPC we send the result back
853 -- Otherwise, do nothing else than deallocation
855 if C_Message_Id /= 0 then
857 -- Build Header = -C_Message_Id + Result Size
858 -- Provide the request id to the env task of the calling
859 -- stub partition We get the real result stream size : the
860 -- calling stub (in Do_RPC) updates its size to this one
862 D (D_Debug, "Anonymous Task - Build Header");
863 Streams.Allocate (Header);
864 Streams.Integer_Write_Attribute
865 (Header'Access, Integer (-C_Message_Id));
866 Streams.SEC_Write_Attribute
867 (Header'Access,
868 Streams.Get_Stream_Size (Result'Access));
870 -- Get a protocol method to comunicate with the remote
871 -- partition and give the message size
873 D (D_Communication,
874 "Anonymous Task - Lookup for protocol talk to partition" &
875 Partition_ID'Image (C_Partition));
876 Garlic.Initiate_Send
877 (C_Partition,
878 Streams.Get_Stream_Size (Header'Access) +
879 Streams.Get_Stream_Size (Result'Access),
880 C_Protocol,
881 Garlic.Remote_Call);
883 -- Send the header by using the protocol method
885 D (D_Communication,
886 "Anonymous Task - Send Header to partition" &
887 Partition_ID'Image (C_Partition));
888 Garlic.Send
889 (C_Protocol.all,
890 C_Partition,
891 Header'Access);
893 -- Send Result toDo_RPC
895 D (D_Communication,
896 "Anonymous Task - Send Result to partition" &
897 Partition_ID'Image (C_Partition));
898 Garlic.Send
899 (C_Protocol.all,
900 C_Partition,
901 Result'Access);
903 -- Let Garlic know we don't send anymore
905 Garlic.Complete_Send
906 (C_Protocol.all,
907 C_Partition);
908 Streams.Deallocate (Header);
909 end if;
911 Streams.Deallocate (Params);
912 Streams.Deallocate (Result);
913 end;
915 -- Enqueue into the anonymous task free list : become inactive
917 Garbage_Collector.Deallocate (Whoami);
919 end loop;
921 exception
922 when others =>
923 D (D_Exception, "exception in Anonymous_Task_Type body");
924 raise;
925 end Anonymous_Task_Type;
927 -----------------
928 -- Environment --
929 -----------------
931 task body Environnement is
932 Partition : Partition_ID;
933 Message_Size : Ada.Streams.Stream_Element_Count;
934 Result_Size : Ada.Streams.Stream_Element_Count;
935 Message_Id : Message_Id_Type;
936 Header : aliased Params_Stream_Type (Header_Size);
937 Protocol : Protocol_Access;
938 Anonymous : Anonymous_Task_Node_Access;
940 begin
941 -- Wait the Partition_RPC_Receiver to be set
943 accept Start;
944 D (D_Elaborate, "Environment task elaborated");
946 loop
947 -- We receive first a fixed size message : the header
948 -- Header = Message Id + Message Size
950 Streams.Allocate (Header);
952 -- Garlic provides the size of the received message and the
953 -- protocol to use to communicate with the calling partition
955 Garlic.Initiate_Receive
956 (Partition,
957 Message_Size,
958 Protocol,
959 Garlic.Remote_Call);
960 D (D_Communication,
961 "Environment task - Receive protocol to talk to active partition" &
962 Partition_ID'Image (Partition));
964 -- Extract the header to route the message either to
965 -- an anonymous task (Message Id > 0 <=> Request Id)
966 -- or to a waiting task (Message Id < 0 <=> Reply Id)
968 D (D_Communication,
969 "Environment task - Receive Header from partition" &
970 Partition_ID'Image (Partition));
971 Garlic.Receive
972 (Protocol.all,
973 Partition,
974 Header'Access);
976 -- Evaluate the remaining size of the message
978 Message_Size := Message_Size -
979 Streams.Get_Stream_Size (Header'Access);
981 -- Extract from header : message id and message size
983 Streams.Integer_Read_Attribute (Header'Access, Message_Id);
984 Streams.SEC_Read_Attribute (Header'Access, Result_Size);
986 if Streams.Get_Stream_Size (Header'Access) /= 0 then
988 -- If there are stream elements left in the header ???
990 D (D_Exception, "Header is not empty");
991 raise Program_Error;
993 end if;
995 if Message_Id < 0 then
997 -- The message was sent by a receiving stub : wake up the
998 -- calling task - We have a reply there
1000 D (D_Debug, "Environment Task - Receive Reply from partition" &
1001 Partition_ID'Image (Partition));
1002 Dispatcher.Wake_Up (-Message_Id, Result_Size);
1004 else
1005 -- The message was send by a calling stub : get an anonymous
1006 -- task to perform the job
1008 D (D_Debug, "Environment Task - Receive Request from partition" &
1009 Partition_ID'Image (Partition));
1010 Garbage_Collector.Allocate (Anonymous);
1012 -- We subtracted the size of the header from the size of the
1013 -- global message in order to provide immediatly Params size
1015 Anonymous.Element.Start
1016 (Message_Id,
1017 Partition,
1018 Message_Size,
1019 Result_Size,
1020 Protocol);
1022 end if;
1024 -- Deallocate header : unnecessary - WARNING
1026 Streams.Deallocate (Header);
1028 end loop;
1030 exception
1031 when others =>
1032 D (D_Exception, "exception in Environment");
1033 raise;
1034 end Environnement;
1036 begin
1037 -- Set debugging information
1039 Debugging.Set_Environment_Variable ("RPC");
1040 Debugging.Set_Debugging_Name ("D", D_Debug);
1041 Debugging.Set_Debugging_Name ("E", D_Exception);
1042 Debugging.Set_Debugging_Name ("C", D_Communication);
1043 Debugging.Set_Debugging_Name ("Z", D_Elaborate);
1044 D (D_Elaborate, "To be elaborated");
1046 -- When this body is elaborated we should ensure that RCI name server
1047 -- has been already elaborated : this means that Establish_RPC_Receiver
1048 -- has already been called and that Partition_RPC_Receiver is set
1050 Environnement.Start;
1051 D (D_Elaborate, "ELABORATED");
1053 end System.RPC;