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