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