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