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 --          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 ------------------------------------------------------------------------------
  33
  34 --  Version for ???
  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    --  ??? 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?
  49
  50    use type Ada.Streams.Stream_Element_Count;
  51    use type Ada.Streams.Stream_Element_Offset;
  52
  53    use type Garlic.Protocol_Access;
  54    use type Garlic.Lock_Method;
  55
  56    Max_Of_Message_Id : constant := 127;
  57
  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.
  67
  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
  70
  71    type Message_Length_Per_Request is array (Request_Id_Type)
  72       of Ada.Streams.Stream_Element_Count;
  73
  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
  78
  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
  82
  83    Partition_RPC_Receiver : RPC_Receiver;
  84    --  Cache the RPC_Recevier passed by Establish_RPC_Receiver
  85
  86    type Anonymous_Task_Node;
  87
  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
  92
  93    task type Anonymous_Task_Type (Self : Anonymous_Task_Node_Access) is
  94
  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
 109
 110    end Anonymous_Task_Type;
 111
 112    type Anonymous_Task_Access is access Anonymous_Task_Type;
 113
 114    type Anonymous_Task_List is record
 115       Head     : Anonymous_Task_Node_Access;
 116       Tail     : Anonymous_Task_Node_Access;
 117    end record;
 118
 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.
 125
 126    protected Garbage_Collector is
 127
 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
 132
 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.
 137
 138    private
 139
 140       Anonymous_List : Anonymous_Task_Node_Access;
 141       --  The list root of inactive anonymous tasks
 142
 143    end Garbage_Collector;
 144
 145    task Dispatcher is
 146
 147       entry New_Request (Request : out Request_Id_Type);
 148       --  To get a new request
 149
 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
 154
 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
 160
 161    end Dispatcher;
 162
 163    task Environnement is
 164
 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
 169
 170    end Environnement;
 171
 172    protected Partition_Receiver is
 173
 174       entry Is_Set;
 175       --  Blocks if the Partition_RPC_Receiver has not been set
 176
 177       procedure Set;
 178       --  Done by Establish_RPC_Receiver when Partition_RPC_Receiver
 179       --  is known
 180
 181    private
 182
 183       Was_Set : Boolean := False;
 184       --  True when Partition_RPC_Receiver has been set
 185
 186    end Partition_Receiver;
 187    --  Anonymous tasks have to wait for the Partition_RPC_Receiver
 188    --  to be established
 189
 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
 196
 197    package Debugging is new System.RPC.Net_Trace (Debug_Level, "RPC : ");
 198    --  Debugging package
 199
 200    procedure D
 201      (Flag : Debug_Level; Info : String) renames Debugging.Debug;
 202    --  Shortcut
 203
 204    ------------------------
 205    -- Partition_Receiver --
 206    ------------------------
 207
 208    protected body Partition_Receiver is
 209
 210       -------------------------------
 211       -- Partition_Receiver.Is_Set --
 212       -------------------------------
 213
 214       entry Is_Set when Was_Set is
 215       begin
 216          null;
 217       end Is_Set;
 218
 219       ----------------------------
 220       -- Partition_Receiver.Set --
 221       ----------------------------
 222
 223       procedure Set is
 224       begin
 225          Was_Set := True;
 226       end Set;
 227
 228    end Partition_Receiver;
 229
 230    ---------------
 231    -- Head_Node --
 232    ---------------
 233
 234    procedure Head_Node
 235      (Index  : out Packet_Node_Access;
 236       Stream : Params_Stream_Type)
 237    is
 238    begin
 239       Index := Stream.Extra.Head;
 240
 241    exception
 242       when others =>
 243          D (D_Exception, "exception in Head_Node");
 244          raise;
 245    end Head_Node;
 246
 247    ---------------
 248    -- Tail_Node --
 249    ---------------
 250
 251    procedure Tail_Node
 252      (Index  : out Packet_Node_Access;
 253       Stream : Params_Stream_Type)
 254    is
 255    begin
 256       Index := Stream.Extra.Tail;
 257
 258    exception
 259       when others =>
 260          D (D_Exception, "exception in Tail_Node");
 261          raise;
 262    end Tail_Node;
 263
 264    ---------------
 265    -- Null_Node --
 266    ---------------
 267
 268    function Null_Node (Index : Packet_Node_Access) return Boolean is
 269    begin
 270       return Index = null;
 271
 272    exception
 273       when others =>
 274          D (D_Exception, "exception in Null_Node");
 275          raise;
 276    end Null_Node;
 277
 278    ----------------------
 279    -- Delete_Head_Node --
 280    ----------------------
 281
 282    procedure Delete_Head_Node (Stream : in out Params_Stream_Type) is
 283
 284       procedure Free is
 285         new Unchecked_Deallocation
 286         (Packet_Node, Packet_Node_Access);
 287
 288       Next_Node : Packet_Node_Access := Stream.Extra.Head.Next;
 289
 290    begin
 291       --  Delete head node and free memory usage
 292
 293       Free (Stream.Extra.Head);
 294       Stream.Extra.Head := Next_Node;
 295
 296       --  If the extra storage is empty, update tail as well
 297
 298       if Stream.Extra.Head = null then
 299          Stream.Extra.Tail := null;
 300       end if;
 301
 302    exception
 303       when others =>
 304          D (D_Exception, "exception in Delete_Head_Node");
 305          raise;
 306    end Delete_Head_Node;
 307
 308    ---------------
 309    -- Next_Node --
 310    ---------------
 311
 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
 316
 317       if Node = null then
 318          raise Stream_Error;
 319       else
 320          Node := Node.Next;
 321       end if;
 322
 323    exception
 324       when others =>
 325          D (D_Exception, "exception in Next_Node");
 326          raise;
 327    end Next_Node;
 328
 329    ---------------------
 330    -- Append_New_Node --
 331    ---------------------
 332
 333    procedure Append_New_Node (Stream : in out Params_Stream_Type) is
 334       Index : Packet_Node_Access;
 335
 336    begin
 337       --  Set Index to the end of the linked list
 338
 339       Tail_Node (Index, Stream);
 340
 341       if Null_Node (Index) then
 342
 343          --  The list is empty : set head as well
 344
 345          Stream.Extra.Head := new Packet_Node;
 346          Stream.Extra.Tail := Stream.Extra.Head;
 347
 348       else
 349          --  The list is not empty : link new node with tail
 350
 351          Stream.Extra.Tail.Next := new Packet_Node;
 352          Stream.Extra.Tail := Stream.Extra.Tail.Next;
 353
 354       end if;
 355
 356    exception
 357       when others =>
 358          D (D_Exception, "exception in Append_New_Node");
 359          raise;
 360    end Append_New_Node;
 361
 362    ----------
 363    -- Read --
 364    ----------
 365
 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;
 371
 372    -----------
 373    -- Write --
 374    -----------
 375
 376    procedure Write
 377      (Stream : in out Params_Stream_Type;
 378       Item   : Ada.Streams.Stream_Element_Array)
 379      renames System.RPC.Streams.Write;
 380
 381    -----------------------
 382    -- Garbage_Collector --
 383    -----------------------
 384
 385    protected body Garbage_Collector is
 386
 387       --------------------------------
 388       -- Garbage_Collector.Allocate --
 389       --------------------------------
 390
 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;
 394
 395       begin
 396          --  If the list is empty, allocate a new anonymous task
 397          --  Otherwise, reuse the first queued anonymous task
 398
 399          if Anonymous_List = null then
 400
 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
 405
 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);
 410
 411          else
 412             --  Extract one task from the list
 413             --  Set the Next field to null to avoid possible bugs
 414
 415             New_Anonymous_Task_Node  := Anonymous_List;
 416             Anonymous_List := Anonymous_List.Next;
 417             New_Anonymous_Task_Node.Next := null;
 418
 419          end if;
 420
 421          --  Item is an out parameter
 422
 423          Item := New_Anonymous_Task_Node;
 424
 425       exception
 426          when others =>
 427             D (D_Exception, "exception in Allocate (Anonymous Task)");
 428             raise;
 429       end Allocate;
 430
 431       ----------------------------------
 432       -- Garbage_Collector.Deallocate --
 433       ----------------------------------
 434
 435       procedure Deallocate (Item : in out Anonymous_Task_Node_Access) is
 436       begin
 437          --  Enqueue the task in the free list
 438
 439          Item.Next := Anonymous_List;
 440          Anonymous_List := Item;
 441
 442       exception
 443          when others =>
 444             D (D_Exception, "exception in Deallocate (Anonymous Task)");
 445             raise;
 446       end Deallocate;
 447
 448    end Garbage_Collector;
 449
 450    ------------
 451    -- Do_RPC --
 452    ------------
 453
 454    procedure Do_RPC
 455      (Partition  : Partition_ID;
 456       Params     : access Params_Stream_Type;
 457       Result     : access Params_Stream_Type)
 458    is
 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;
 463
 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)
 476
 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
 480
 481       if Partition /= Garlic.Get_My_Partition_ID then
 482
 483          --  Get a request id to be resumed when the reply arrives
 484
 485          Dispatcher.New_Request (Request);
 486
 487          --  Build header = request (2) + result.initial_size (3)
 488
 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);
 495
 496          --  Get a protocol method to communicate with the remote partition
 497          --  and give the message size
 498
 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);
 508
 509          --  Send the header by using the protocol method
 510
 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)
 517
 518          --  The header is deallocated
 519
 520          Streams.Deallocate (Header);
 521
 522          --  Send Params from Do_RPC
 523
 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)
 530
 531          --  Let Garlic know we have nothing else to send
 532
 533          Garlic.Complete_Send
 534            (Protocol.all,
 535             Partition);
 536          D (D_Debug, "Do_RPC - Suspend");
 537
 538          --  Wait for a reply and get the reply message length
 539
 540          Dispatcher.Wait_On (Request) (R_Length);
 541          D (D_Debug, "Do_RPC - Resume");
 542
 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
 549
 550             Streams.Allocate (New_Result);
 551
 552             --  Receive the reply message from receiving stub
 553
 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);
 560
 561             --  Let Garlic know we have nothing else to receive
 562
 563             Garlic.Complete_Receive
 564               (Protocol.all,
 565                Partition);
 566
 567             --  Update calling stub Result stream
 568
 569             D (D_Debug, "Do_RPC - Reconstruct Result");
 570             Streams.Deallocate (Result.all);
 571             Result.Initial := New_Result.Initial;
 572             Streams.Dump ("|||", Result.all);
 573
 574          end;
 575
 576       else
 577          --  Do RPC locally and first wait for Partition_RPC_Receiver to be
 578          --  set
 579
 580          Partition_Receiver.Is_Set;
 581          D (D_Debug, "Do_RPC - Locally");
 582          Partition_RPC_Receiver.all (Params, Result);
 583
 584       end if;
 585
 586    exception
 587       when others =>
 588          D (D_Exception, "exception in Do_RPC");
 589          raise;
 590    end Do_RPC;
 591
 592    ------------
 593    -- Do_APC --
 594    ------------
 595
 596    procedure Do_APC
 597      (Partition  : Partition_ID;
 598       Params     : access Params_Stream_Type)
 599    is
 600       Message_Id : Message_Id_Type := 0;
 601       Protocol   : Protocol_Access;
 602       Header     : aliased Params_Stream_Type (Header_Size);
 603
 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
 608
 609       if Partition /= Garlic.Get_My_Partition_ID then
 610
 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
 615
 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);
 622
 623          --  Get a protocol method to communicate with the remote partition
 624          --  and give the message size
 625
 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);
 635
 636          --  Send the header by using the protocol method
 637
 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);
 644
 645          --  The header is deallocated
 646
 647          Streams.Deallocate (Header);
 648
 649          --  Send Params from Do_APC
 650
 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);
 657
 658          --  Let Garlic know we have nothing else to send
 659
 660          Garlic.Complete_Send
 661            (Protocol.all,
 662             Partition);
 663       else
 664
 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
 670
 671             Partition_Receiver.Is_Set;
 672             D (D_Debug, "Do_APC - Locally");
 673             Partition_RPC_Receiver.all (Params, Result'Access);
 674
 675          end;
 676
 677       end if;
 678
 679    exception
 680       when others =>
 681          D (D_Exception, "exception in Do_APC");
 682          raise;
 683    end Do_APC;
 684
 685    ----------------------------
 686    -- Establish_RPC_Receiver --
 687    ----------------------------
 688
 689    procedure Establish_RPC_Receiver
 690      (Partition : Partition_ID;
 691       Receiver  : RPC_Receiver)
 692    is
 693    begin
 694       --  Set Partition_RPC_Receiver and allow RPC mechanism
 695
 696       Partition_RPC_Receiver := Receiver;
 697       Partition_Receiver.Set;
 698       D (D_Elaborate, "Partition_Receiver is set");
 699
 700    exception
 701       when others =>
 702          D (D_Exception, "exception in Establish_RPC_Receiver");
 703          raise;
 704    end Establish_RPC_Receiver;
 705
 706    ----------------
 707    -- Dispatcher --
 708    ----------------
 709
 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;
 714
 715    begin
 716       loop
 717          --  Three services:
 718
 719          --    New_Request to get an entry in Dispatcher table
 720
 721          --    Wait_On for Do_RPC calls
 722
 723          --    Wake_Up called by environment task when a Do_RPC receives
 724          --    the result of its remote call
 725
 726          select
 727             accept New_Request (Request : out Request_Id_Type) do
 728                Request := Last_Request;
 729
 730                --  << TODO >>
 731                --  ??? Avaibility check
 732
 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;
 738
 739             end New_Request;
 740
 741          or
 742             accept Wake_Up
 743               (Request : Request_Id_Type;
 744                Length  : Ada.Streams.Stream_Element_Count)
 745             do
 746                --  The environment reads the header and has been notified
 747                --  of the reply id and the size of the result message
 748
 749                Current_Rqst := Request;
 750                Current_Size := Length;
 751
 752             end Wake_Up;
 753
 754             --  << TODO >>
 755             --  ??? Must be select with delay for aborted tasks
 756
 757             select
 758
 759                accept Wait_On (Current_Rqst)
 760                  (Length  : out Ada.Streams.Stream_Element_Count)
 761                do
 762                   Length := Current_Size;
 763                end Wait_On;
 764
 765             or
 766                --  To free the Dispatcher when a task is aborted
 767
 768                delay 1.0;
 769
 770             end select;
 771
 772          or
 773             terminate;
 774          end select;
 775
 776       end loop;
 777
 778    exception
 779       when others =>
 780          D (D_Exception, "exception in Dispatcher body");
 781          raise;
 782    end Dispatcher;
 783
 784    -------------------------
 785    -- Anonymous_Task_Type --
 786    -------------------------
 787
 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
 795
 796    begin
 797       loop
 798          --  Get a new RPC to execute
 799
 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)
 807             do
 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;
 814          or
 815             terminate;
 816          end select;
 817
 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);
 822
 823          begin
 824             --  We reconstruct all the client context : Params and Result
 825             --  with the SAME size, then we receive Params from calling stub
 826
 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);
 834
 835             --  Let Garlic know we don't receive anymore
 836
 837             Garlic.Complete_Receive
 838                (C_Protocol.all,
 839                 C_Partition);
 840
 841             --  Check that Partition_RPC_Receiver has been set
 842
 843             Partition_Receiver.Is_Set;
 844
 845             --  Do it locally
 846
 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);
 851
 852             --  If this was a RPC we send the result back
 853             --  Otherwise, do nothing else than deallocation
 854
 855             if C_Message_Id /= 0 then
 856
 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
 861
 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));
 869
 870                --  Get a protocol method to comunicate with the remote
 871                --  partition and give the message size
 872
 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);
 882
 883                --  Send the header by using the protocol method
 884
 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);
 892
 893                --  Send Result toDo_RPC
 894
 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);
 902
 903                --  Let Garlic know we don't send anymore
 904
 905                Garlic.Complete_Send
 906                  (C_Protocol.all,
 907                   C_Partition);
 908                Streams.Deallocate (Header);
 909             end if;
 910
 911             Streams.Deallocate (Params);
 912             Streams.Deallocate (Result);
 913          end;
 914
 915          --  Enqueue into the anonymous task free list : become inactive
 916
 917          Garbage_Collector.Deallocate (Whoami);
 918
 919       end loop;
 920
 921    exception
 922       when others =>
 923          D (D_Exception, "exception in Anonymous_Task_Type body");
 924          raise;
 925    end Anonymous_Task_Type;
 926
 927    -----------------
 928    -- Environment --
 929    -----------------
 930
 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;
 939
 940    begin
 941       --  Wait the Partition_RPC_Receiver to be set
 942
 943       accept Start;
 944       D (D_Elaborate, "Environment task elaborated");
 945
 946       loop
 947          --  We receive first a fixed size message : the header
 948          --  Header = Message Id + Message Size
 949
 950          Streams.Allocate (Header);
 951
 952          --  Garlic provides the size of the received message and the
 953          --  protocol to use to communicate with the calling partition
 954
 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));
 963
 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)
 967
 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);
 975
 976          --  Evaluate the remaining size of the message
 977
 978          Message_Size := Message_Size -
 979             Streams.Get_Stream_Size (Header'Access);
 980
 981          --  Extract from header : message id and message size
 982
 983          Streams.Integer_Read_Attribute (Header'Access, Message_Id);
 984          Streams.SEC_Read_Attribute (Header'Access, Result_Size);
 985
 986          if Streams.Get_Stream_Size (Header'Access) /= 0 then
 987
 988             --  If there are stream elements left in the header ???
 989
 990             D (D_Exception, "Header is not empty");
 991             raise Program_Error;
 992
 993          end if;
 994
 995          if Message_Id < 0 then
 996
 997             --  The message was sent by a receiving stub : wake up the
 998             --  calling task - We have a reply there
 999
1000             D (D_Debug, "Environment Task - Receive Reply from partition" &
1001                Partition_ID'Image (Partition));
1002             Dispatcher.Wake_Up (-Message_Id, Result_Size);
1003
1004          else
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 subtracted 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
1031       when others =>
1032          D (D_Exception, "exception in Environment");
1033          raise;
1034    end Environnement;
1035
1036 begin
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;