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