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 34with Unchecked_Deallocation; 35with Ada.Streams; 36 37with System.RPC.Net_Trace; 38with System.RPC.Garlic; 39with System.RPC.Streams; 40pragma Elaborate (System.RPC.Garlic); 41 42package 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 informations, 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 1034begin 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 1051end System.RPC; 1052