gcc/ada/9drpc.adb

   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 --                            $Revision: 1.2 $                              --
  10 --                                                                          --
  11 --     Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc.     --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 with Unchecked_Deallocation;
  37 with Ada.Streams;
  38
  39 with System.RPC.Net_Trace;
  40 with System.RPC.Garlic;
  41 with System.RPC.Streams;
  42 pragma Elaborate (System.RPC.Garlic);
  43
  44 package body System.RPC is
  45
  46    use type Ada.Streams.Stream_Element_Count;
  47    use type Ada.Streams.Stream_Element_Offset;
  48
  49    use type Garlic.Protocol_Access;
  50    use type Garlic.Lock_Method;
  51
  52    Max_Of_Message_Id : constant := 127;
  53
  54    subtype Message_Id_Type is
  55       Integer range -Max_Of_Message_Id .. Max_Of_Message_Id;
  56    --  A message id is either a request id or reply id. A message id is
  57    --  provided with a message to a receiving stub which uses the opposite
  58    --  as a reply id. A message id helps to retrieve to which task is
  59    --  addressed a reply. When the environment task receives a message, the
  60    --  message id is extracted : a positive message id stands for a call, a
  61    --  negative message id stands for a reply. A null message id stands for
  62    --  an asynchronous request.
  63
  64    subtype Request_Id_Type is Message_Id_Type range 1 .. Max_Of_Message_Id;
  65    --  When a message id is positive, it is a request
  66
  67    type Message_Length_Per_Request is array (Request_Id_Type)
  68       of Ada.Streams.Stream_Element_Count;
  69
  70    Header_Size : Ada.Streams.Stream_Element_Count
  71       := Streams.Get_Integer_Initial_Size +
  72          Streams.Get_SEC_Initial_Size;
  73    --  Initial size needed for frequently used header streams
  74
  75    Stream_Error : exception;
  76    --  Occurs when a read procedure is executed on an empty stream
  77    --  or when a write procedure is executed on a full stream
  78
  79    Partition_RPC_Receiver : RPC_Receiver;
  80    --  Cache the RPC_Recevier passed by Establish_RPC_Receiver
  81
  82    type Anonymous_Task_Node;
  83
  84    type Anonymous_Task_Node_Access is access Anonymous_Task_Node;
  85    --  Types we need to construct a singly linked list of anonymous tasks
  86    --  This pool is maintained to avoid a task creation each time a RPC
  87    --  occurs - to be cont'd
  88
  89    task type Anonymous_Task_Type (Self : Anonymous_Task_Node_Access) is
  90
  91       entry Start
  92          (Message_Id   : in Message_Id_Type;
  93           Partition    : in Partition_ID;
  94           Params_Size  : in Ada.Streams.Stream_Element_Count;
  95           Result_Size  : in Ada.Streams.Stream_Element_Count;
  96           Protocol     : in Garlic.Protocol_Access);
  97       --  This entry provides an anonymous task a remote call to perform
  98       --  This task calls for a
  99       --  Request id is provided to construct the reply id by using
 100       --  -Request. Partition is used to send the reply message. Params_Size
 101       --  is the size of the calling stub Params stream. Then, Protocol
 102       --  (used by the environment task previously) allows to extract the
 103       --  message following the header (The header is extracted by the
 104       --  environment task)
 105
 106    end Anonymous_Task_Type;
 107
 108    type Anonymous_Task_Access is access Anonymous_Task_Type;
 109
 110    type Anonymous_Task_List is
 111       record
 112          Head     : Anonymous_Task_Node_Access;
 113          Tail     : Anonymous_Task_Node_Access;
 114       end record;
 115
 116    type Anonymous_Task_Node is
 117       record
 118          Element : Anonymous_Task_Access;
 119          Next    : Anonymous_Task_Node_Access;
 120       end record;
 121    --  Types we need to construct a singly linked list of anonymous tasks
 122    --  This pool is maintained to avoid a task creation each time a RPC
 123    --  occurs
 124
 125    protected Garbage_Collector is
 126
 127       procedure Allocate
 128          (Item : out Anonymous_Task_Node_Access);
 129       --  Anonymous task pool management : if there is an anonymous task
 130       --  left, use it. Otherwise, allocate a new one
 131
 132       procedure Deallocate
 133          (Item : in out Anonymous_Task_Node_Access);
 134       --  Anonymous task pool management : queue this task in the pool
 135       --  of inactive anonymous tasks.
 136    private
 137
 138       Anonymous_List : Anonymous_Task_Node_Access;
 139       --  The list root of inactive anonymous tasks
 140
 141    end Garbage_Collector;
 142
 143    task Dispatcher is
 144
 145       entry New_Request (Request : out Request_Id_Type);
 146       --  To get a new request
 147
 148       entry Wait_On (Request_Id_Type)
 149         (Length : out Ada.Streams.Stream_Element_Count);
 150       --  To block the calling stub when it waits for a reply
 151       --  When it is resumed, we provide the size of the reply
 152
 153       entry Wake_Up
 154         (Request : in Request_Id_Type;
 155          Length  : in Ada.Streams.Stream_Element_Count);
 156       --  To wake up the calling stub when the environnement task has
 157       --  received a reply for this request
 158
 159    end Dispatcher;
 160
 161    task Environnement is
 162
 163       entry Start;
 164       --  Receive no message until Partition_Receiver is set
 165       --  Establish_RPC_Receiver decides when the environment task
 166       --  is allowed to start
 167
 168    end Environnement;
 169
 170    protected Partition_Receiver is
 171
 172       entry Is_Set;
 173       --  Blocks if the Partition_RPC_Receiver has not been set
 174
 175       procedure Set;
 176       --  Done by Establish_RPC_Receiver when Partition_RPC_Receiver
 177       --  is known
 178
 179    private
 180
 181       Was_Set : Boolean := False;
 182       --  True when Partition_RPC_Receiver has been set
 183
 184    end Partition_Receiver;
 185    --  Anonymous tasks have to wait for the Partition_RPC_Receiver
 186    --  to be established
 187
 188    type Debug_Level is
 189       (D_Elaborate,        --  About the elaboration of this package
 190        D_Communication,    --  About calls to Send and Receive
 191        D_Debug,            --  Verbose
 192        D_Exception);       --  Exception handler
 193    --  Debugging levels
 194
 195    package Debugging is new System.RPC.Net_Trace (Debug_Level, "RPC : ");
 196    --  Debugging package
 197
 198    procedure D
 199      (Flag : in Debug_Level; Info : in String) renames Debugging.Debug;
 200    --  Shortcut
 201
 202    ------------------------
 203    -- Partition_Receiver --
 204    ------------------------
 205
 206    protected body Partition_Receiver is
 207
 208       -------------------------------
 209       -- Partition_Receiver.Is_Set --
 210       -------------------------------
 211
 212       entry Is_Set when Was_Set is
 213       begin
 214          null;
 215       end Is_Set;
 216
 217       ----------------------------
 218       -- Partition_Receiver.Set --
 219       ----------------------------
 220
 221       procedure Set is
 222       begin
 223          Was_Set := True;
 224       end Set;
 225
 226    end Partition_Receiver;
 227
 228    ---------------
 229    -- Head_Node --
 230    ---------------
 231
 232    procedure Head_Node
 233      (Index  :    out Packet_Node_Access;
 234       Stream : in     Params_Stream_Type) is
 235    begin
 236       Index := Stream.Extra.Head;
 237    exception when others =>
 238       D (D_Exception, "exception in Head_Node");
 239       raise;
 240    end Head_Node;
 241
 242    ---------------
 243    -- Tail_Node --
 244    ---------------
 245
 246    procedure Tail_Node
 247      (Index  :    out Packet_Node_Access;
 248       Stream : in     Params_Stream_Type) is
 249    begin
 250       Index := Stream.Extra.Tail;
 251    exception when others =>
 252       D (D_Exception, "exception in Tail_Node");
 253       raise;
 254    end Tail_Node;
 255
 256    ---------------
 257    -- Null_Node --
 258    ---------------
 259
 260    function Null_Node
 261      (Index : in Packet_Node_Access) return Boolean is
 262    begin
 263       return Index = null;
 264    exception when others =>
 265       D (D_Exception, "exception in Null_Node");
 266       raise;
 267    end Null_Node;
 268
 269    ----------------------
 270    -- Delete_Head_Node --
 271    ----------------------
 272
 273    procedure Delete_Head_Node
 274      (Stream : in out Params_Stream_Type) is
 275
 276       procedure Free is
 277         new Unchecked_Deallocation
 278         (Packet_Node, Packet_Node_Access);
 279
 280       Next_Node : Packet_Node_Access := Stream.Extra.Head.Next;
 281
 282    begin
 283
 284       --  Delete head node and free memory usage
 285
 286       Free (Stream.Extra.Head);
 287       Stream.Extra.Head := Next_Node;
 288
 289       --  If the extra storage is empty, update tail as well
 290
 291       if Stream.Extra.Head = null then
 292          Stream.Extra.Tail := null;
 293       end if;
 294
 295    exception when others =>
 296       D (D_Exception, "exception in Delete_Head_Node");
 297       raise;
 298    end Delete_Head_Node;
 299
 300    ---------------
 301    -- Next_Node --
 302    ---------------
 303
 304    procedure Next_Node
 305      (Node : in out Packet_Node_Access) is
 306    begin
 307
 308       --  Node is set to the next node
 309       --  If not possible, Stream_Error is raised
 310
 311       if Node = null then
 312          raise Stream_Error;
 313       else
 314          Node := Node.Next;
 315       end if;
 316
 317    exception when others =>
 318       D (D_Exception, "exception in Next_Node");
 319       raise;
 320    end Next_Node;
 321
 322    ---------------------
 323    -- Append_New_Node --
 324    ---------------------
 325
 326    procedure Append_New_Node
 327      (Stream : in out Params_Stream_Type) is
 328       Index : Packet_Node_Access;
 329    begin
 330
 331       --  Set Index to the end of the linked list
 332
 333       Tail_Node (Index, Stream);
 334
 335       if Null_Node (Index) then
 336
 337          --  The list is empty : set head as well
 338
 339          Stream.Extra.Head := new Packet_Node;
 340          Stream.Extra.Tail := Stream.Extra.Head;
 341
 342       else
 343
 344          --  The list is not empty : link new node with tail
 345
 346          Stream.Extra.Tail.Next := new Packet_Node;
 347          Stream.Extra.Tail := Stream.Extra.Tail.Next;
 348
 349       end if;
 350
 351    exception when others =>
 352       D (D_Exception, "exception in Append_New_Node");
 353       raise;
 354    end Append_New_Node;
 355
 356    ----------
 357    -- Read --
 358    ----------
 359
 360    procedure Read
 361      (Stream : in out Params_Stream_Type;
 362       Item   : out Ada.Streams.Stream_Element_Array;
 363       Last   : out Ada.Streams.Stream_Element_Offset) renames
 364       System.RPC.Streams.Read;
 365
 366    -----------
 367    -- Write --
 368    -----------
 369
 370    procedure Write
 371      (Stream : in out Params_Stream_Type;
 372       Item   : in Ada.Streams.Stream_Element_Array) renames
 373       System.RPC.Streams.Write;
 374
 375    -----------------------
 376    -- Garbage_Collector --
 377    -----------------------
 378
 379    protected body Garbage_Collector is
 380
 381       --------------------------------
 382       -- Garbage_Collector.Allocate --
 383       --------------------------------
 384
 385       procedure Allocate
 386          (Item : out Anonymous_Task_Node_Access) is
 387          New_Anonymous_Task_Node : Anonymous_Task_Node_Access;
 388          Anonymous_Task          : Anonymous_Task_Access;
 389       begin
 390
 391          --  If the list is empty, allocate a new anonymous task
 392          --  Otherwise, reuse the first queued anonymous task
 393
 394          if Anonymous_List = null then
 395
 396             --  Create a new anonymous task
 397             --  Provide this new task with its id to allow it
 398             --  to enqueue itself into the free anonymous task list
 399             --  with the function Deallocate
 400
 401             New_Anonymous_Task_Node := new Anonymous_Task_Node;
 402             Anonymous_Task :=
 403              new Anonymous_Task_Type (New_Anonymous_Task_Node);
 404             New_Anonymous_Task_Node.all := (Anonymous_Task, null);
 405
 406          else
 407
 408             --  Extract one task from the list
 409             --  Set the Next field to null to avoid possible bugs
 410
 411             New_Anonymous_Task_Node  := Anonymous_List;
 412             Anonymous_List := Anonymous_List.Next;
 413             New_Anonymous_Task_Node.Next := null;
 414
 415          end if;
 416
 417          --  Item is an out parameter
 418
 419          Item := New_Anonymous_Task_Node;
 420
 421       exception when others =>
 422          D (D_Exception, "exception in Allocate (Anonymous Task)");
 423          raise;
 424       end Allocate;
 425
 426       ----------------------------------
 427       -- Garbage_Collector.Deallocate --
 428       ----------------------------------
 429
 430       procedure Deallocate
 431         (Item : in out Anonymous_Task_Node_Access) is
 432       begin
 433
 434          --  Enqueue the task in the free list
 435
 436          Item.Next := Anonymous_List;
 437          Anonymous_List := Item;
 438
 439       exception when others =>
 440          D (D_Exception, "exception in Deallocate (Anonymous Task)");
 441          raise;
 442       end Deallocate;
 443
 444    end Garbage_Collector;
 445
 446    ------------
 447    -- Do_RPC --
 448    ------------
 449
 450    procedure Do_RPC
 451      (Partition  : in Partition_ID;
 452       Params     : access Params_Stream_Type;
 453       Result     : access Params_Stream_Type) is
 454       Protocol   : Protocol_Access;
 455       Request    : Request_Id_Type;
 456       Header     : aliased Params_Stream_Type (Header_Size);
 457       R_Length   : Ada.Streams.Stream_Element_Count;
 458    begin
 459
 460       --  Parameters order :
 461       --       Opcode   (provided and used by garlic)
 462       --   (1) Size     (provided by s-rpc and used by garlic)
 463       --                (size of (2)+(3)+(4)+(5))
 464       --   (2) Request  (provided by calling stub (resp receiving stub) and
 465       --                 used by anonymous task (resp Do_RPC))
 466       --                *** ZERO IF APC ***
 467       --   (3) Res.len. (provided by calling stubs and used by anonymous task)
 468       --                *** ZERO IF APC ***
 469       --   (4) Receiver (provided by calling stubs and used by anonymous task)
 470       --   (5) Params   (provided by calling stubs and used by anonymous task)
 471
 472       --  The call is a remote call or a local call. A local call occurs
 473       --  when the pragma All_Calls_Remote has been specified. Do_RPC is
 474       --  called and the execution has to be performed in the PCS
 475
 476       if Partition /= Garlic.Get_My_Partition_ID then
 477
 478          --  Get a request id to be resumed when the reply arrives
 479
 480          Dispatcher.New_Request (Request);
 481
 482          --  Build header = request (2) + result.initial_size (3)
 483
 484          D (D_Debug, "Do_RPC - Build header");
 485          Streams.Allocate (Header);
 486          Streams.Integer_Write_Attribute            --  (2)
 487            (Header'Access, Request);
 488          System.RPC.Streams.SEC_Write_Attribute     --  (3)
 489            (Header'Access, Result.Initial_Size);
 490
 491          --  Get a protocol method to communicate with the remote partition
 492          --  and give the message size
 493
 494          D (D_Communication,
 495             "Do_RPC - Lookup for protocol to talk to partition" &
 496             Partition_ID'Image (Partition));
 497          Garlic.Initiate_Send
 498            (Partition,
 499             Streams.Get_Stream_Size (Header'Access) +
 500             Streams.Get_Stream_Size (Params), --  (1)
 501             Protocol,
 502             Garlic.Remote_Call);
 503
 504          --  Send the header by using the protocol method
 505
 506          D (D_Communication, "Do_RPC - Send Header to partition" &
 507             Partition_ID'Image (Partition));
 508          Garlic.Send
 509            (Protocol.all,
 510             Partition,
 511             Header'Access);                         --  (2) + (3)
 512
 513          --  The header is deallocated
 514
 515          Streams.Deallocate (Header);
 516
 517          --  Send Params from Do_RPC
 518
 519          D (D_Communication, "Do_RPC - Send Params to partition" &
 520             Partition_ID'Image (Partition));
 521          Garlic.Send
 522            (Protocol.all,
 523             Partition,
 524             Params);                                --  (4) + (5)
 525
 526          --  Let Garlic know we have nothing else to send
 527
 528          Garlic.Complete_Send
 529            (Protocol.all,
 530             Partition);
 531          D (D_Debug, "Do_RPC - Suspend");
 532
 533          --  Wait for a reply and get the reply message length
 534
 535          Dispatcher.Wait_On (Request) (R_Length);
 536          D (D_Debug, "Do_RPC - Resume");
 537
 538          declare
 539             New_Result : aliased Params_Stream_Type (R_Length);
 540          begin
 541
 542             --  Adjust the Result stream size right now to be able to load
 543             --  the stream in one receive call. Create a temporary resutl
 544             --  that will be substituted to Do_RPC one
 545
 546             Streams.Allocate (New_Result);
 547
 548             --  Receive the reply message from receiving stub
 549
 550             D (D_Communication, "Do_RPC - Receive Result from partition" &
 551             Partition_ID'Image (Partition));
 552             Garlic.Receive
 553               (Protocol.all,
 554                Partition,
 555                New_Result'Access);
 556
 557             --  Let Garlic know we have nothing else to receive
 558
 559             Garlic.Complete_Receive
 560               (Protocol.all,
 561                Partition);
 562
 563             --  Update calling stub Result stream
 564
 565             D (D_Debug, "Do_RPC - Reconstruct Result");
 566             Streams.Deallocate (Result.all);
 567             Result.Initial := New_Result.Initial;
 568             Streams.Dump ("|||", Result.all);
 569
 570          end;
 571
 572       else
 573
 574          --  Do RPC locally and first wait for Partition_RPC_Receiver to be
 575          --  set
 576
 577          Partition_Receiver.Is_Set;
 578          D (D_Debug, "Do_RPC - Locally");
 579          Partition_RPC_Receiver.all (Params, Result);
 580
 581       end if;
 582
 583    exception when others =>
 584       D (D_Exception, "exception in Do_RPC");
 585       raise;
 586    end Do_RPC;
 587
 588    ------------
 589    -- Do_APC --
 590    ------------
 591
 592    procedure Do_APC
 593      (Partition  : in Partition_ID;
 594       Params     : access Params_Stream_Type) is
 595       Message_Id : Message_Id_Type := 0;
 596       Protocol   : Protocol_Access;
 597       Header     : aliased Params_Stream_Type (Header_Size);
 598    begin
 599
 600       --  For more informations, see above
 601       --  Request = 0 as we are not waiting for a reply message
 602       --  Result length = 0 as we don't expect a result at all
 603
 604       if Partition /= Garlic.Get_My_Partition_ID then
 605
 606          --  Build header = request (2) + result.initial_size (3)
 607          --  As we have an APC, the request id is null to indicate
 608          --  to the receiving stub that we do not expect a reply
 609          --  This comes from 0 = -0
 610
 611          D (D_Debug, "Do_APC - Build Header");
 612          Streams.Allocate (Header);
 613          Streams.Integer_Write_Attribute
 614            (Header'Access, Integer (Message_Id));
 615          Streams.SEC_Write_Attribute
 616            (Header'Access, 0);
 617
 618          --  Get a protocol method to communicate with the remote partition
 619          --  and give the message size
 620
 621          D (D_Communication,
 622             "Do_APC - Lookup for protocol to talk to partition" &
 623             Partition_ID'Image (Partition));
 624          Garlic.Initiate_Send
 625            (Partition,
 626             Streams.Get_Stream_Size (Header'Access) +
 627             Streams.Get_Stream_Size (Params),
 628             Protocol,
 629             Garlic.Remote_Call);
 630
 631          --  Send the header by using the protocol method
 632
 633          D (D_Communication, "Do_APC - Send Header to partition" &
 634             Partition_ID'Image (Partition));
 635          Garlic.Send
 636            (Protocol.all,
 637             Partition,
 638             Header'Access);
 639
 640          --  The header is deallocated
 641
 642          Streams.Deallocate (Header);
 643
 644          --  Send Params from Do_APC
 645
 646          D (D_Communication, "Do_APC - Send Params to partition" &
 647             Partition_ID'Image (Partition));
 648          Garlic.Send
 649            (Protocol.all,
 650             Partition,
 651             Params);
 652
 653          --  Let Garlic know we have nothing else to send
 654
 655          Garlic.Complete_Send
 656            (Protocol.all,
 657             Partition);
 658       else
 659
 660          declare
 661             Result   : aliased Params_Stream_Type (0);
 662          begin
 663
 664             --  Result is here a dummy parameter
 665             --  No reason to deallocate as it is not allocated at all
 666
 667             Partition_Receiver.Is_Set;
 668             D (D_Debug, "Do_APC - Locally");
 669             Partition_RPC_Receiver.all (Params, Result'Access);
 670
 671          end;
 672
 673       end if;
 674
 675    exception when others =>
 676       D (D_Exception, "exception in Do_APC");
 677       raise;
 678    end Do_APC;
 679
 680    ----------------------------
 681    -- Establish_RPC_Receiver --
 682    ----------------------------
 683
 684    procedure Establish_RPC_Receiver (
 685           Partition : in Partition_ID;
 686           Receiver  : in RPC_Receiver) is
 687    begin
 688
 689       --  Set Partition_RPC_Receiver and allow RPC mechanism
 690
 691       Partition_RPC_Receiver := Receiver;
 692       Partition_Receiver.Set;
 693       D (D_Elaborate, "Partition_Receiver is set");
 694
 695    exception when others =>
 696       D (D_Exception, "exception in Establish_RPC_Receiver");
 697       raise;
 698    end Establish_RPC_Receiver;
 699
 700    ----------------
 701    -- Dispatcher --
 702    ----------------
 703
 704    task body Dispatcher is
 705       Last_Request : Request_Id_Type := Request_Id_Type'First;
 706       Current_Rqst : Request_Id_Type := Request_Id_Type'First;
 707       Current_Size : Ada.Streams.Stream_Element_Count;
 708    begin
 709
 710       loop
 711
 712          --  Three services :
 713          --  New_Request to get an entry in Dispatcher table
 714          --  Wait_On for Do_RPC calls
 715          --  Wake_Up called by environment task when a Do_RPC receives
 716          --  the result of its remote call
 717
 718          select
 719
 720             accept New_Request
 721               (Request : out Request_Id_Type) do
 722                Request := Last_Request;
 723
 724                --  << TODO >>
 725                --  Avaibility check
 726
 727                if Last_Request = Request_Id_Type'Last then
 728                   Last_Request := Request_Id_Type'First;
 729                else
 730                   Last_Request := Last_Request + 1;
 731                end if;
 732
 733             end New_Request;
 734
 735          or
 736
 737             accept Wake_Up
 738               (Request : in Request_Id_Type;
 739                Length  : in Ada.Streams.Stream_Element_Count) do
 740
 741                --  The environment reads the header and has been notified
 742                --  of the reply id and the size of the result message
 743
 744                Current_Rqst := Request;
 745                Current_Size := Length;
 746
 747             end Wake_Up;
 748
 749             --  << TODO >>
 750             --  Must be select with delay for aborted tasks
 751
 752             select
 753
 754                accept Wait_On (Current_Rqst)
 755                  (Length  : out Ada.Streams.Stream_Element_Count) do
 756                   Length := Current_Size;
 757                end Wait_On;
 758
 759             or
 760
 761                --  To free the Dispatcher when a task is aborted
 762
 763                delay 1.0;
 764
 765             end select;
 766
 767          or
 768
 769             terminate;
 770
 771          end select;
 772
 773       end loop;
 774
 775    exception when others =>
 776       D (D_Exception, "exception in Dispatcher body");
 777       raise;
 778    end Dispatcher;
 779
 780    -------------------------
 781    -- Anonymous_Task_Type --
 782    -------------------------
 783
 784    task body Anonymous_Task_Type is
 785       Whoami       : Anonymous_Task_Node_Access := Self;
 786       C_Message_Id : Message_Id_Type;                  --  Current Message Id
 787       C_Partition  : Partition_ID;                     --  Current Partition
 788       Params_S     : Ada.Streams.Stream_Element_Count; --  Params message size
 789       Result_S     : Ada.Streams.Stream_Element_Count; --  Result message size
 790       C_Protocol   : Protocol_Access;                  --  Current Protocol
 791    begin
 792
 793       loop
 794
 795          --  Get a new RPC to execute
 796
 797          select
 798             accept Start
 799               (Message_Id   : in Message_Id_Type;
 800                Partition    : in Partition_ID;
 801                Params_Size  : in Ada.Streams.Stream_Element_Count;
 802                Result_Size  : in Ada.Streams.Stream_Element_Count;
 803                Protocol     : in Protocol_Access) do
 804                C_Message_Id := Message_Id;
 805                C_Partition  := Partition;
 806                Params_S     := Params_Size;
 807                Result_S     := Result_Size;
 808                C_Protocol   := Protocol;
 809             end Start;
 810          or
 811             terminate;
 812          end select;
 813
 814          declare
 815             Params   : aliased Params_Stream_Type (Params_S);
 816             Result   : aliased Params_Stream_Type (Result_S);
 817             Header   : aliased Params_Stream_Type (Header_Size);
 818          begin
 819
 820             --  We reconstruct all the client context : Params and Result
 821             --  with the SAME size, then we receive Params from calling stub
 822
 823             D (D_Communication,
 824                "Anonymous Task - Receive Params from partition" &
 825                Partition_ID'Image (C_Partition));
 826             Garlic.Receive
 827                (C_Protocol.all,
 828                 C_Partition,
 829                 Params'Access);
 830
 831             --  Let Garlic know we don't receive anymore
 832
 833             Garlic.Complete_Receive
 834                (C_Protocol.all,
 835                 C_Partition);
 836
 837             --  Check that Partition_RPC_Receiver has been set
 838
 839             Partition_Receiver.Is_Set;
 840
 841             --  Do it locally
 842
 843             D (D_Debug,
 844                "Anonymous Task - Perform Partition_RPC_Receiver for request" &
 845                Message_Id_Type'Image (C_Message_Id));
 846             Partition_RPC_Receiver (Params'Access, Result'Access);
 847
 848             --  If this was a RPC we send the result back
 849             --  Otherwise, do nothing else than deallocation
 850
 851             if C_Message_Id /= 0 then
 852
 853                --  Build Header = -C_Message_Id + Result Size
 854                --  Provide the request id to the env task of the calling
 855                --  stub partition We get the real result stream size : the
 856                --  calling stub (in Do_RPC) updates its size to this one
 857
 858                D (D_Debug, "Anonymous Task - Build Header");
 859                Streams.Allocate (Header);
 860                Streams.Integer_Write_Attribute
 861                  (Header'Access, Integer (-C_Message_Id));
 862                Streams.SEC_Write_Attribute
 863                  (Header'Access,
 864                   Streams.Get_Stream_Size (Result'Access));
 865
 866
 867                --  Get a protocol method to comunicate with the remote
 868                --  partition and give the message size
 869
 870                D (D_Communication,
 871                   "Anonymous Task - Lookup for protocol talk to partition" &
 872                   Partition_ID'Image (C_Partition));
 873                Garlic.Initiate_Send
 874                  (C_Partition,
 875                   Streams.Get_Stream_Size (Header'Access) +
 876                   Streams.Get_Stream_Size (Result'Access),
 877                   C_Protocol,
 878                   Garlic.Remote_Call);
 879
 880                --  Send the header by using the protocol method
 881
 882                D (D_Communication,
 883                   "Anonymous Task - Send Header to partition" &
 884                   Partition_ID'Image (C_Partition));
 885                Garlic.Send
 886                  (C_Protocol.all,
 887                   C_Partition,
 888                   Header'Access);
 889
 890                --  Send Result toDo_RPC
 891
 892                D (D_Communication,
 893                   "Anonymous Task - Send Result to partition" &
 894                   Partition_ID'Image (C_Partition));
 895                Garlic.Send
 896                  (C_Protocol.all,
 897                   C_Partition,
 898                   Result'Access);
 899
 900                --  Let Garlic know we don't send anymore
 901
 902                Garlic.Complete_Send
 903                  (C_Protocol.all,
 904                   C_Partition);
 905                Streams.Deallocate (Header);
 906
 907             end if;
 908
 909             Streams.Deallocate (Params);
 910             Streams.Deallocate (Result);
 911
 912          end;
 913
 914          --  Enqueue into the anonymous task free list : become inactive
 915
 916          Garbage_Collector.Deallocate (Whoami);
 917
 918       end loop;
 919
 920    exception when others =>
 921       D (D_Exception, "exception in Anonymous_Task_Type body");
 922       raise;
 923    end Anonymous_Task_Type;
 924
 925    -----------------
 926    -- Environment --
 927    -----------------
 928
 929    task body Environnement is
 930       Partition    : Partition_ID;
 931       Message_Size : Ada.Streams.Stream_Element_Count;
 932       Result_Size  : Ada.Streams.Stream_Element_Count;
 933       Message_Id   : Message_Id_Type;
 934       Header       : aliased Params_Stream_Type (Header_Size);
 935       Protocol     : Protocol_Access;
 936       Anonymous    : Anonymous_Task_Node_Access;
 937    begin
 938
 939       --  Wait the Partition_RPC_Receiver to be set
 940
 941       accept Start;
 942       D (D_Elaborate, "Environment task elaborated");
 943
 944       loop
 945
 946          --  We receive first a fixed size message : the header
 947          --  Header = Message Id + Message Size
 948
 949          Streams.Allocate (Header);
 950
 951          --  Garlic provides the size of the received message and the
 952          --  protocol to use to communicate with the calling partition
 953
 954          Garlic.Initiate_Receive
 955             (Partition,
 956              Message_Size,
 957              Protocol,
 958              Garlic.Remote_Call);
 959          D (D_Communication,
 960             "Environment task - Receive protocol to talk to active partition" &
 961             Partition_ID'Image (Partition));
 962
 963          --  Extract the header to route the message either to
 964          --  an anonymous task (Message Id > 0 <=> Request Id)
 965          --  or to a waiting task (Message Id < 0 <=> Reply Id)
 966
 967          D (D_Communication,
 968             "Environment task - Receive Header from partition" &
 969             Partition_ID'Image (Partition));
 970          Garlic.Receive
 971             (Protocol.all,
 972              Partition,
 973              Header'Access);
 974
 975          --  Evaluate the remaining size of the message
 976
 977          Message_Size := Message_Size -
 978             Streams.Get_Stream_Size (Header'Access);
 979
 980          --  Extract from header : message id and message size
 981
 982          Streams.Integer_Read_Attribute (Header'Access, Message_Id);
 983          Streams.SEC_Read_Attribute (Header'Access, Result_Size);
 984
 985          if Streams.Get_Stream_Size (Header'Access) /= 0 then
 986
 987             --  If there are stream elements left in the header ???
 988
 989             D (D_Exception, "Header is not empty");
 990             raise Program_Error;
 991
 992          end if;
 993
 994          if Message_Id < 0 then
 995
 996             --  The message was sent by a receiving stub : wake up the
 997             --  calling task - We have a reply there
 998
 999             D (D_Debug, "Environment Task - Receive Reply from partition" &
1000                Partition_ID'Image (Partition));
1001             Dispatcher.Wake_Up (-Message_Id, Result_Size);
1002
1003          else
1004
1005             --  The message was send by a calling stub : get an anonymous
1006             --  task to perform the job
1007
1008             D (D_Debug, "Environment Task - Receive Request from partition" &
1009                Partition_ID'Image (Partition));
1010             Garbage_Collector.Allocate (Anonymous);
1011
1012             --  We substracted the size of the header from the size of the
1013             --  global message in order to provide immediatly Params size
1014
1015             Anonymous.Element.Start
1016               (Message_Id,
1017                Partition,
1018                Message_Size,
1019                Result_Size,
1020                Protocol);
1021
1022          end if;
1023
1024          --  Deallocate header : unnecessary - WARNING
1025
1026          Streams.Deallocate (Header);
1027
1028       end loop;
1029
1030    exception when others =>
1031       D (D_Exception, "exception in Environment");
1032       raise;
1033    end Environnement;
1034
1035 begin
1036
1037    --  Set debugging information
1038
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");
1045
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
1049
1050    Environnement.Start;
1051    D (D_Elaborate, "ELABORATED");
1052
1053 end System.RPC;