1------------------------------------------------------------------------------ 2-- -- 3-- GPR TECHNOLOGY -- 4-- -- 5-- Copyright (C) 2012-2016, AdaCore -- 6-- -- 7-- This is free software; you can redistribute it and/or modify it under -- 8-- terms of the GNU General Public License as published by the Free Soft- -- 9-- ware Foundation; either version 3, or (at your option) any later ver- -- 10-- sion. This software is distributed in the hope that it will be useful, -- 11-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 12-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 13-- License for more details. You should have received a copy of the GNU -- 14-- General Public License distributed with GNAT; see file COPYING. If not, -- 15-- see <http://www.gnu.org/licenses/>. -- 16-- -- 17------------------------------------------------------------------------------ 18 19with Ada.Calendar.Formatting; 20with Ada.Calendar.Time_Zones; use Ada.Calendar; 21with Ada.Characters.Handling; use Ada.Characters.Handling; 22with Ada.Containers.Indefinite_Hashed_Maps; 23with Ada.Containers.Indefinite_Ordered_Sets; 24with Ada.Containers.Indefinite_Vectors; 25with Ada.Containers.Ordered_Sets; 26with Ada.Containers.Vectors; 27with Ada.Directories; use Ada.Directories; 28with Ada.Exceptions; use Ada.Exceptions; 29with Ada.Finalization; use Ada.Finalization; 30with Ada.Strings.Equal_Case_Insensitive; 31with Ada.Strings.Fixed; use Ada.Strings; 32with Ada.Strings.Hash_Case_Insensitive; 33with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; 34with Ada.Text_IO; use Ada.Text_IO; 35with Ada.Unchecked_Deallocation; 36with Interfaces; 37with System.Multiprocessors; use System; 38 39with GNAT.Command_Line; use GNAT; 40with GNAT.CRC32; 41with GNAT.Exception_Traces; 42with GNAT.OS_Lib; use GNAT.OS_Lib; 43with GNAT.Sockets; use GNAT.Sockets; 44with GNAT.String_Split; use GNAT.String_Split; 45with GNAT.Strings; 46with GNAT.Traceback.Symbolic; use GNAT.Traceback; 47 use GNAT.Traceback.Symbolic; 48 49with Gpr_Util; use Gpr_Util; 50with GPR_Version; 51with Gprbuild.Compilation; use Gprbuild.Compilation; 52with Gprbuild.Compilation.Process; use Gprbuild.Compilation.Process; 53with Gprbuild.Compilation.Protocol; use Gprbuild.Compilation.Protocol; 54with GprConfig.Knowledge; use GprConfig.Knowledge; 55with GPR; use GPR; 56with GPR.Opt; use GPR.Opt; 57with GPR.Env; use GPR.Env; 58with GPR.Names; use GPR.Names; 59with GPR.Part; use GPR.Part; 60with GPR.Proc; use GPR.Proc; 61with GPR.Tree; use GPR.Tree; 62with GPR.Snames; use GPR.Snames; 63 64procedure Gprslave is 65 66 use Ada; 67 68 type UID is mod 9999; 69 70 -- The Status is shared by the same build master object. It first has a 71 -- reference counter to free the memory associated with this status and 72 -- a boolean used a a mutex to lock/unlock the object to allow proper 73 -- concurrent access. 74 75 type Status is record 76 Id : UID; 77 Locked : Boolean := False; 78 Count : Natural := 0; 79 end record; 80 81 type Shared_Status is access Status; 82 83 package String_Set is new Containers.Indefinite_Vectors (Positive, String); 84 85 -- Data for a build master 86 87 type Build_Master is new Finalization.Controlled with record 88 Channel : Communication_Channel; 89 -- Communication with build master 90 Socket : Socket_Type; 91 Project_Name : Unbounded_String; 92 Target : Unbounded_String; 93 Build_Env : Unbounded_String; 94 Included_Artifact_Patterns : String_Split.Slice_Set; 95 Sync : Boolean; 96 Status : Shared_Status; 97 end record; 98 99 overriding procedure Initialize (Builder : in out Build_Master); 100 overriding procedure Adjust (Builder : in out Build_Master); 101 overriding procedure Finalize (Builder : in out Build_Master); 102 103 protected Controlled_Build_Master is 104 procedure Initialize (Builder : in out Build_Master); 105 procedure Adjust (Builder : in out Build_Master); 106 procedure Finalize (Builder : in out Build_Master); 107 end Controlled_Build_Master; 108 109 package Builder is 110 111 function "<" (B1, B2 : Build_Master) return Boolean is 112 (To_C (B1.Socket) < To_C (B2.Socket)); 113 114 function "=" (B1, B2 : Build_Master) return Boolean is 115 (B1.Socket = B2.Socket); 116 117 package Set is new Containers.Ordered_Sets (Build_Master); 118 119 end Builder; 120 121 package Builder_Set renames Builder.Set; 122 123 -- Representation of a job data 124 125 type Stages is 126 (J_None, J_Created, J_Waiting, J_Running, J_Terminated, J_Killed); 127 128 type Job_Data is record 129 Cmd : Command; 130 Id : Remote_Id := -1; -- job id must be uniq across all slaves 131 Pid : Process_Id := OS_Lib.Invalid_Pid; -- the OS process id 132 Dep_Dir : Unbounded_String; 133 Dep_File : Unbounded_String; 134 Obj_File : Unbounded_String; 135 Output : Unbounded_String; 136 Build_Sock : Socket_Type; -- key used to get the corresponding builder 137 Stage : Stages := J_None; 138 end record with Dynamic_Predicate => 139 (case Job_Data.Stage is 140 when J_None => 141 Job_Data.Id = -1, 142 143 when J_Created | J_Waiting => 144 Job_Data.Pid = OS_Lib.Invalid_Pid 145 and then Kind (Job_Data.Cmd) in EX | CU 146 and then Job_Data.Build_Sock /= No_Socket, 147 148 when J_Running | J_Terminated | J_Killed => 149 Job_Data.Pid /= OS_Lib.Invalid_Pid 150 and then Kind (Job_Data.Cmd) in EX | CU 151 and then Job_Data.Build_Sock /= No_Socket); 152 153 No_Job : constant Job_Data := 154 (Id => -1, 155 Pid => OS_Lib.Invalid_Pid, 156 Stage => J_None, 157 others => <>); 158 159 function "<" (J1, J2 : Job_Data) return Boolean is 160 (Pid_To_Integer (J1.Pid) < Pid_To_Integer (J2.Pid)); 161 162 function "=" (J1, J2 : Job_Data) return Boolean is 163 (Pid_To_Integer (J1.Pid) = Pid_To_Integer (J2.Pid)); 164 165 package Job_Data_Set is new Containers.Ordered_Sets (Job_Data); 166 167 package To_Run_Set is new Containers.Vectors (Positive, Job_Data); 168 169 function Get_Arg 170 (Builder : Build_Master; Value : String) return String with Inline; 171 -- Returns Value with possible translation of the local repositories 172 173 function Get_Args 174 (Builder : Build_Master; Slices : Slice_Set) return Argument_List; 175 -- Returns an Argument_List corresponding to the Slice_Set 176 177 function Image (Value : Long_Integer) return String; 178 -- Return Value string representation without the leading space 179 180 function Work_Directory (Builder : Build_Master) return String; 181 -- Directory where compilation are to be done, this is the directory named 182 -- after the project under the Root_Directory. 183 184 procedure Parse_Command_Line; 185 -- Parse the command line options, set variables below accordingly 186 187 function Get_Slave_Id return Remote_Id; 188 189 function Is_Active_Build_Master (Builder : Build_Master) return Boolean is 190 (Builder.Project_Name /= Null_Unbounded_String 191 and then Builder.Status /= null); 192 193 procedure Close_Builder (Builder : in out Build_Master; Ack : Boolean); 194 -- Close the channel and socket and remove the builder from the slave. This 195 -- procedure never fails. Send a OK message if Ack is True. 196 197 procedure Activate_Symbolic_Traceback; 198 -- Activate symbolic trace-back 199 200 -- 201 -- Belows are the main objects which handle the concurrent requests 202 -- 203 204 procedure Wait_For_Master; 205 -- Wait for a build master to connect, initialize the global communication 206 -- channel. This procedure is run under the environment task. Send the 207 -- slave config to the build master. Either a builder object is created and 208 -- inserted into the Builders protected object or the builder is rejected 209 -- because of inconsistent state: 210 -- 211 -- 1. the builder and the slave are not using the same compiler. 212 -- 2. the slave is already handling compilation for this project 213 -- environment. 214 215 task Wait_Requests; 216 -- Waiting for incoming requests from the masters, take corresponding 217 -- actions. Three actions are handled here: 218 -- 219 -- 1. EX - execute a compilation 220 -- A compilation request is inserted into To_Run protected object. 221 -- 222 -- 2. CU - execute a clean-up 223 -- A clean-up request is inserted into To_Run protected object. 224 -- 225 -- 3. EC - stop execution for the given builder 226 227 task Execute_Job; 228 -- Task running a maximum of Max_Process compilation simultaneously. These 229 -- jobs are taken from the To_Run protected object (a FIFO list). 230 -- 231 -- Jobs taken from To_Run protected object are removed, executed 232 -- asynchronously and inserted into the Running protected object with 233 -- the corresponding process Id and builder. 234 -- 235 -- IMPORTANT NOTE : this is the only task that can change the working 236 -- directory (Set_Directory for example). This makes locking circuitry 237 -- lighter and more efficient. 238 239 task type Wait_Completion; 240 -- Waiting for completion of compilation jobs. The Pid is retreived with 241 -- the corresponding builder, then it sends back the response to the build 242 -- masters. The response is OK or NOK depending on compilation result. If 243 -- OK the auxiliaries files (.ali, .o) are sent back to the build master. 244 -- 245 -- This is the only task with multiple instance. As sending back resulting 246 -- objects and ALI files can take some time haaving multiple instance 247 -- permit to send results to different builders simultaneously. 248 249 protected Builders is 250 251 -- Protected builders data set (used by environment task and the 252 -- Protocol_Handler). 253 -- 254 -- The list of builder, one for each build master. Inserted here when a 255 -- compilation starts and removed when an end-of-compilation message is 256 -- received or a master is interrupted. 257 258 procedure Insert (Builder : Build_Master); 259 -- Add Builder into the set 260 261 procedure Remove (Builder : in out Build_Master); 262 -- Remove Builder from the set 263 264 function Get (Socket : Socket_Type) return Build_Master; 265 -- Get the builder using Socket 266 267 function Exists (Socket : Socket_Type) return Boolean; 268 -- Returns True if the build master corresponding to socket is found. 269 -- False otherwise. 270 271 entry Get_Socket_Set (Socket_Set : out Socket_Set_Type); 272 -- Get a socket set for all builders 273 274 procedure Initialize (Builder : in out Build_Master); 275 -- Set the UID for this build master. This Id is only used in log 276 -- message to identify a specific build. 277 278 function Working_Dir_Exists (Directory : String) return Boolean; 279 -- Returns True if Directory is already used by a registered build 280 -- master. This is to ensure that a unique build will happen in a 281 -- given directory. 282 283 entry Lock (Builder : in out Build_Master); 284 -- Lock builder against concurrent use, must be released 285 286 procedure Release (Builder : in out Build_Master); 287 -- Release builder locked with entry above 288 289 private 290 291 entry Try_Lock (Builder : in out Build_Master); 292 -- The lock is already taken, the tasks are queued here to wait for the 293 -- builder to be released. 294 295 Current_Id : UID := 0; 296 Builders : Builder_Set.Set; 297 To_Check : Natural := 0; -- number of task to let go through Try_Lock 298 end Builders; 299 300 protected To_Run is 301 302 -- Queue of Job to run, A FIFO list of jobs comming from all registered 303 -- builders. 304 305 procedure Push (Job : Job_Data) 306 with Pre => Job.Stage = J_Created; 307 308 entry Pop (Job : out Job_Data); 309 -- with Post => Job.Stage = J_Waiting; 310 -- ??? with the post condition we have a warning for Pop not being 311 -- referenced. 312 313 private 314 Set : To_Run_Set.Vector; 315 end To_Run; 316 317 protected Running is 318 319 -- Set of running jobs. Removed when the compilation terminates or when 320 -- killed because of a builder is interrupted. 321 322 procedure Start 323 (Job : in out Job_Data; 324 Driver : String; 325 Options : Argument_List; 326 Out_File : String; 327 Obj_File : String; 328 Dep_File : String; 329 Dep_Dir : String; 330 Pid : out Process_Id) 331 with Pre => Job.Stage = J_Waiting, Post => Job.Stage = J_Running; 332 -- Start and register a new running job 333 334 procedure Get (Job : out Job_Data; Pid : Process_Id) 335 with Post => Job = No_Job or else Job.Stage = J_Terminated; 336 -- Get Job having the given Pid 337 338 procedure Set_Max (Max : Positive); 339 -- Set the maximum running processes simultaneously 340 341 entry Wait_Slot; 342 -- Wait for a running slot to be available 343 344 entry Wait; 345 -- Wait for at least one running process 346 347 procedure Kill_Processes (Socket : Socket_Type); 348 -- Kill all processes whose builder is registered with Socket. This 349 -- is used when a builder is interrupted to kill all corresponding 350 -- processes. 351 352 function Count return Natural; 353 -- Number of job running 354 355 private 356 Set : Job_Data_Set.Set; 357 Dead : Job_Data_Set.Set; -- job which failed to start 358 N_Count : Natural := 0; -- actual number of running process 359 Max : Natural := 0; 360 end Running; 361 362 -- Ensure that all IO are serialized, especially the spawn of process which 363 -- must never happen during other IO. This is needed as the spawned process 364 -- will inherit the standard IO descriptors. 365 366 protected IO is 367 368 procedure Message 369 (Builder : Build_Master; 370 Str : String; 371 Is_Debug : Boolean := False; 372 Force : Boolean := False) with Inline; 373 procedure Message 374 (Str : String; 375 Is_Debug : Boolean := False; 376 Force : Boolean := False) with Inline; 377 -- Display a message (in verbose mode) and adds a leading timestamp. 378 -- Also display the message in debug mode if Is_Debug is set. 379 380 procedure Spawn 381 (Driver : String; 382 Options : Argument_List; 383 Out_File : String; 384 Pid : out Process_Id); 385 386 end IO; 387 388 Compiler_Path : constant OS_Lib.String_Access := 389 Locate_Exec_On_Path ("gnatls"); 390 391 Slave_Id : Remote_Id; 392 -- Host Id used to compose a unique job id across all running slaves 393 394 -- Command line parameters statuses 395 396 Port : aliased Integer; 397 Max_Processes : aliased Integer; 398 Max_Responses : aliased Integer; 399 Help : aliased Boolean := False; 400 Verbose : aliased Boolean := False; 401 Debug : aliased Boolean := False; 402 Root_Directory : aliased GNAT.Strings.String_Access := 403 new String'(Current_Directory); 404 -- Root directoty for the gprslave environment. All projects sources and 405 -- compilations are done under this directory. 406 Hash : aliased GNAT.Strings.String_Access; 407 408 -- Running instances statuses 409 410 Address : Sock_Addr_Type; 411 Server : Socket_Type; 412 Index : Long_Integer := 0; 413 414 -- Knowledge base 415 416 Base : Knowledge_Base; 417 Selected_Targets_Set : Targets_Set_Id; 418 419 -- Handle response 420 421 type Response_Handler_Set is array (Positive range <>) of Wait_Completion; 422 type Response_Handler_Set_Access is access Response_Handler_Set; 423 424 Response_Handlers : Response_Handler_Set_Access with Unreferenced; 425 -- Sending response to a build master may take some time as the object file 426 -- is sent back over the socket with the corresponding dependency file. 427 428 ------------ 429 -- Adjust -- 430 ------------ 431 432 overriding procedure Adjust (Builder : in out Build_Master) is 433 begin 434 Controlled_Build_Master.Adjust (Builder); 435 end Adjust; 436 437 --------------------------------- 438 -- Activate_Symbolic_Traceback -- 439 --------------------------------- 440 441 procedure Activate_Symbolic_Traceback is 442 begin 443 Exception_Traces.Trace_On (Exception_Traces.Unhandled_Raise); 444 Exception_Traces.Set_Trace_Decorator 445 (Traceback.Symbolic.Symbolic_Traceback'Access); 446 end Activate_Symbolic_Traceback; 447 448 -------------- 449 -- Builders -- 450 -------------- 451 452 protected body Builders is 453 454 ------------ 455 -- Exists -- 456 ------------ 457 458 function Exists (Socket : Socket_Type) return Boolean is 459 Builder : Build_Master; 460 begin 461 Builder.Socket := Socket; 462 return Builder_Set.Has_Element (Builders.Find (Builder)); 463 end Exists; 464 465 --------- 466 -- Get -- 467 --------- 468 469 function Get (Socket : Socket_Type) return Build_Master is 470 Builder : Build_Master; 471 Pos : Builder_Set.Cursor; 472 begin 473 Builder.Socket := Socket; 474 475 Pos := Builders.Find (Builder); 476 477 if Builder_Set.Has_Element (Pos) then 478 Builder := Builder_Set.Element (Pos); 479 end if; 480 481 return Builder; 482 end Get; 483 484 -------------------- 485 -- Get_Socket_Set -- 486 -------------------- 487 488 entry Get_Socket_Set (Socket_Set : out Socket_Set_Type) 489 when not Builders.Is_Empty is 490 begin 491 Empty (Socket_Set); 492 493 for B of Builders loop 494 Set (Socket_Set, B.Socket); 495 end loop; 496 end Get_Socket_Set; 497 498 ---------------- 499 -- Initialize -- 500 ---------------- 501 502 procedure Initialize (Builder : in out Build_Master) is 503 begin 504 Builder.Status.Id := Current_Id; 505 Current_Id := Current_Id + 1; 506 end Initialize; 507 508 ------------ 509 -- Insert -- 510 ------------ 511 512 procedure Insert (Builder : Build_Master) is 513 begin 514 Builders.Insert (Builder); 515 end Insert; 516 517 ---------- 518 -- Lock -- 519 ---------- 520 521 entry Lock (Builder : in out Build_Master) when True is 522 begin 523 if Builder.Status.Locked then 524 requeue Try_Lock; 525 else 526 Builder.Status.Locked := True; 527 end if; 528 end Lock; 529 530 ------------- 531 -- Release -- 532 ------------- 533 534 procedure Release (Builder : in out Build_Master) is 535 begin 536 Builder.Status.Locked := False; 537 if Try_Lock'Count > 0 then 538 To_Check := To_Check + Try_Lock'Count; 539 end if; 540 end Release; 541 542 ------------ 543 -- Remove -- 544 ------------ 545 546 procedure Remove (Builder : in out Build_Master) is 547 begin 548 Builders.Exclude (Builder); 549 Release (Builder); 550 end Remove; 551 552 -------------- 553 -- Try_Lock -- 554 -------------- 555 556 entry Try_Lock (Builder : in out Build_Master) when To_Check > 0 is 557 begin 558 To_Check := To_Check - 1; 559 560 if Builder.Status.Locked then 561 requeue Try_Lock; 562 else 563 Builder.Status.Locked := True; 564 end if; 565 end Try_Lock; 566 567 ------------------------ 568 -- Working_Dir_Exists -- 569 ------------------------ 570 571 function Working_Dir_Exists (Directory : String) return Boolean is 572 begin 573 for B of Builders loop 574 if Work_Directory (B) = Directory then 575 return True; 576 end if; 577 end loop; 578 return False; 579 end Working_Dir_Exists; 580 581 end Builders; 582 583 ------------------- 584 -- Close_Builder -- 585 ------------------- 586 587 procedure Close_Builder (Builder : in out Build_Master; Ack : Boolean) is 588 begin 589 -- First unregister the builder 590 591 Builders.Remove (Builder); 592 Running.Kill_Processes (Builder.Socket); 593 594 -- Now close the channel/socket. This routine is used when the builder 595 -- has encountered an error, so the associated socket may be in a bad 596 -- state. Make sure we do not fail here. 597 598 begin 599 -- Send an Ack message before closing if requested 600 601 if Ack then 602 Send_Ok (Builder.Channel); 603 end if; 604 605 Close (Builder.Channel); 606 Close_Socket (Builder.Socket); 607 exception 608 when others => 609 null; 610 end; 611 end Close_Builder; 612 613 ----------------------------- 614 -- Controlled_Build_Master -- 615 ----------------------------- 616 617 protected body Controlled_Build_Master is 618 619 ------------ 620 -- Adjust -- 621 ------------ 622 623 procedure Adjust (Builder : in out Build_Master) is 624 begin 625 Builder.Status.Count := Builder.Status.Count + 1; 626 end Adjust; 627 628 -------------- 629 -- Finalize -- 630 -------------- 631 632 procedure Finalize (Builder : in out Build_Master) is 633 procedure Unchecked_Free is 634 new Unchecked_Deallocation (Status, Shared_Status); 635 S : Shared_Status := Builder.Status; 636 begin 637 Builder.Status := null; 638 639 S.Count := S.Count - 1; 640 641 if S.Count = 0 then 642 Unchecked_Free (S); 643 end if; 644 end Finalize; 645 646 ---------------- 647 -- Initialize -- 648 ---------------- 649 650 procedure Initialize (Builder : in out Build_Master) is 651 begin 652 Builder.Status := new Status'(0, False, 1); 653 end Initialize; 654 655 end Controlled_Build_Master; 656 657 -------------- 658 -- Finalize -- 659 -------------- 660 661 overriding procedure Finalize (Builder : in out Build_Master) is 662 begin 663 Controlled_Build_Master.Finalize (Builder); 664 end Finalize; 665 666 ------------- 667 -- Get_Arg -- 668 ------------- 669 670 function Get_Arg (Builder : Build_Master; Value : String) return String is 671 P : constant Natural := Fixed.Index (Value, WD_Path_Tag); 672 begin 673 if P = 0 then 674 return Value; 675 else 676 return Value (Value'First .. P - 1) 677 & Work_Directory (Builder) 678 & Directory_Separator 679 & Get_Arg (Builder, Value (P + WD_Path_Tag'Length .. Value'Last)); 680 end if; 681 end Get_Arg; 682 683 -------------- 684 -- Get_Args -- 685 -------------- 686 687 function Get_Args 688 (Builder : Build_Master; Slices : Slice_Set) return Argument_List 689 is 690 Args : Argument_List (1 .. Integer (Slice_Count (Slices))); 691 begin 692 for K in Args'Range loop 693 Args (K) := new String' 694 (Get_Arg (Builder, Slice (Slices, Slice_Number (K)))); 695 end loop; 696 697 return Args; 698 end Get_Args; 699 700 ----------------- 701 -- Get_Slave_Id -- 702 ----------------- 703 704 function Get_Slave_Id return Remote_Id is 705 use GNAT.CRC32; 706 use type Interfaces.Unsigned_32; 707 CRC : GNAT.CRC32.CRC32; 708 begin 709 Initialize (CRC); 710 Update (CRC, Host_Name); 711 -- Set the host id as the 32 higher bits 712 return Remote_Id (Get_Value (CRC)) * 2 ** 32; 713 end Get_Slave_Id; 714 715 ----------- 716 -- Image -- 717 ----------- 718 719 function Image (Value : Long_Integer) return String is 720 I : constant String := Long_Integer'Image (Value); 721 begin 722 return (if I (I'First) = '-' 723 then I 724 else I (I'First + 1 .. I'Last)); 725 end Image; 726 727 ---------------- 728 -- Initialize -- 729 ---------------- 730 731 overriding procedure Initialize (Builder : in out Build_Master) is 732 begin 733 Controlled_Build_Master.Initialize (Builder); 734 end Initialize; 735 736 -------- 737 -- IO -- 738 -------- 739 740 protected body IO is 741 742 ------------- 743 -- Message -- 744 ------------- 745 746 procedure Message 747 (Str : String; 748 Is_Debug : Boolean := False; 749 Force : Boolean := False) is 750 begin 751 if Force or (Verbose and not Is_Debug) or (Debug and Is_Debug) then 752 Put_Line 753 ('[' & Calendar.Formatting.Image (Calendar.Clock) & "] " 754 & (if Is_Debug then "# " else " ") & Str); 755 end if; 756 end Message; 757 758 procedure Message 759 (Builder : Build_Master; 760 Str : String; 761 Is_Debug : Boolean := False; 762 Force : Boolean := False) 763 is 764 package UID_IO is new Text_IO.Modular_IO (UID); 765 begin 766 if Force or (Verbose and not Is_Debug) or (Debug and Is_Debug) then 767 UID_IO.Put (Builder.Status.Id, Width => 4); 768 Put (' '); 769 Message (Str, Is_Debug, Force); 770 end if; 771 end Message; 772 773 ----------- 774 -- Spawn -- 775 ----------- 776 777 procedure Spawn 778 (Driver : String; 779 Options : Argument_List; 780 Out_File : String; 781 Pid : out Process_Id) is 782 begin 783 Pid := OS_Lib.Non_Blocking_Spawn (Driver, Options, Out_File); 784 end Spawn; 785 786 end IO; 787 788 ------------------------ 789 -- Parse_Command_Line -- 790 ------------------------ 791 792 procedure Parse_Command_Line is 793 use GNAT.Command_Line; 794 795 procedure Usage; 796 797 procedure Check_Version_And_Help is new 798 Check_Version_And_Help_G (Usage); 799 800 Config : Command_Line_Configuration; 801 802 ----------- 803 -- Usage -- 804 ----------- 805 806 procedure Usage is 807 begin 808 Display_Help (Config); 809 end Usage; 810 811 begin 812 Define_Switch 813 (Config, Help'Access, 814 "-h", Long_Switch => "--help", 815 Help => "display this help message and exit"); 816 817 Define_Switch 818 (Config, Verbose'Access, 819 "-V", Long_Switch => "--version", 820 Help => "display version and exit"); 821 822 Define_Switch 823 (Config, Max_Processes'Access, 824 "-j:", Long_Switch => "--jobs=", 825 Initial => Integer (Multiprocessors.Number_Of_CPUs), 826 Default => Integer (Multiprocessors.Number_Of_CPUs), 827 Help => "set the maximum simultaneous compilation"); 828 829 Define_Switch 830 (Config, Max_Responses'Access, 831 "-r:", Long_Switch => "--response-handler=", 832 Initial => Integer (2), 833 Default => Integer (2), 834 Help => "maximum number of simultaneous responses sent back"); 835 836 Define_Switch 837 (Config, Root_Directory'Access, 838 "-d:", Long_Switch => "--directory=", 839 Help => "set the root directory"); 840 841 Define_Switch 842 (Config, Port'Access, 843 "-p:", Long_Switch => "--port=", 844 Initial => Integer (Default_Port), 845 Default => Integer (Default_Port), 846 Help => "set the port the slave will listen to"); 847 848 Define_Switch 849 (Config, Verbose'Access, 850 "-v", Long_Switch => "--verbose", 851 Help => "verbose mode, display extra information"); 852 853 Define_Switch 854 (Config, Debug'Access, 855 "-vv", Long_Switch => "--debug", 856 Help => "debug mode, display lot of information (imply -v)"); 857 858 Define_Switch 859 (Config, Hash'Access, 860 "-s:", Long_Switch => "--hash=", 861 Help => "specifiy a hash, must match with master"); 862 863 Set_Usage (Config, Usage => "[switches]"); 864 865 Check_Version_And_Help 866 ("GPRSLAVE", 867 "2013", 868 Version_String => GPR_Version.Gpr_Version_String); 869 870 Getopt (Config); 871 872 if Debug then 873 Verbose := True; 874 end if; 875 876 -- To avoid error messages for unknown languages that are not described 877 -- in the XML database, use the quiet mode if Verbose is not set. 878 879 if not Verbose then 880 Opt.Quiet_Output := True; 881 end if; 882 883 -- First ensure Root_Directory is an absolute path-name. This is 884 -- needed to be able to create directory for a specific builder without 885 -- enforcing that the current directory be in a critical section. 886 -- Indeed, it is then possible to create a directory under this 887 -- absolute path-name directly. 888 889 if not Is_Absolute_Path (Root_Directory.all) then 890 891 -- Not an absolute path, this means that we have passed a directory 892 -- relative to the current directory with option -d/--directory. 893 894 declare 895 RD : constant String := Root_Directory.all; 896 begin 897 Free (Root_Directory); 898 Root_Directory := 899 new String'(Ensure_Directory (Current_Directory) & RD); 900 end; 901 end if; 902 903 -- Ensure Root_Directory does not ends with a directory separator 904 905 if Root_Directory (Root_Directory'Last) in '/' | '\' then 906 Delete_Last : declare 907 RD : constant String := Root_Directory 908 (Root_Directory'First .. Root_Directory'Last - 1); 909 begin 910 Free (Root_Directory); 911 Root_Directory := new String'(RD); 912 end Delete_Last; 913 end if; 914 915 Running.Set_Max (Max_Processes); 916 917 exception 918 when Invalid_Switch => 919 OS_Exit (1); 920 921 when Exit_From_Command_Line => 922 OS_Exit (1); 923 end Parse_Command_Line; 924 925 ------------------- 926 -- Wait_Requests -- 927 ------------------- 928 929 task body Wait_Requests is 930 931 type Job_Number is mod 2**32; 932 -- A 32bits integer which wrap around. This is no problem as we want 933 -- to be able to identify running process. There won't be 2**32 process 934 -- running at the same time. So it is safe restart numbering at 0. 935 936 Selector : Selector_Type; 937 R_Socket_Set : Socket_Set_Type; 938 E_Socket_Set : Socket_Set_Type; 939 Empty_Set : Socket_Set_Type; 940 Status : Selector_Status; 941 Builder : Build_Master; 942 Socket : Socket_Type; 943 Jid : Job_Number := 0; 944 begin 945 -- Create selector 946 947 Create_Selector (Selector); 948 Empty (Empty_Set); 949 950 -- For now do not check write status 951 952 Handle_Commands : loop 953 954 -- Wait for some commands from one of the build master 955 956 Builders.Get_Socket_Set (R_Socket_Set); 957 958 Copy (R_Socket_Set, E_Socket_Set); 959 960 Wait_Incoming_Data : loop 961 begin 962 Check_Selector 963 (Selector, R_Socket_Set, Empty_Set, E_Socket_Set, Status); 964 exit Wait_Incoming_Data; 965 exception 966 when E : Socket_Error => 967 if Resolve_Exception (E) /= Interrupted_System_Call then 968 Status := Aborted; 969 exit Wait_Incoming_Data; 970 end if; 971 end; 972 end loop Wait_Incoming_Data; 973 974 if Status /= Aborted then 975 -- Check for socket error first, if a socket is in error just 976 -- close the builder and remove it from the list. From there 977 -- we abort any action. 978 979 Get (E_Socket_Set, Socket); 980 981 if Socket /= No_Socket then 982 Builder := Builders.Get (Socket); 983 IO.Message (Builder, "Error socket signaled", Is_Debug => True); 984 Status := Aborted; 985 end if; 986 end if; 987 988 if Status = Aborted then 989 -- Either the selector has been aborted or the Socket was not 990 -- found in the response. We can suppose that in this case the 991 -- client is killed and we do not have to keep it in the registry. 992 993 Get (R_Socket_Set, Socket); 994 995 if Socket /= No_Socket then 996 Builder := Builders.Get (Socket); 997 Close_Builder (Builder, Ack => False); 998 end if; 999 1000 else 1001 Get (R_Socket_Set, Socket); 1002 1003 if Socket /= No_Socket then 1004 Builder := Builders.Get (Socket); 1005 1006 if Is_Active_Build_Master (Builder) then 1007 Builders.Lock (Builder); 1008 1009 declare 1010 Cmd : constant Command := Get_Command (Builder.Channel); 1011 V : Unbounded_String; 1012 begin 1013 if Debug then 1014 V := To_Unbounded_String 1015 ("command: " & Command_Kind'Image (Kind (Cmd))); 1016 1017 declare 1018 List : constant Argument_List_Access := Args (Cmd); 1019 begin 1020 if List /= null then 1021 for K in List'Range loop 1022 Append (V, ", " & List (K).all); 1023 end loop; 1024 end if; 1025 end; 1026 1027 IO.Message (Builder, To_String (V), Is_Debug => True); 1028 end if; 1029 1030 if Kind (Cmd) = EX then 1031 Record_Job : declare 1032 Id : constant Remote_Id := 1033 Slave_Id + Remote_Id (Jid); 1034 -- Note that the Id above should be unique across 1035 -- all running slaves. This is not the process 1036 -- id, but an id sent back to the build master 1037 -- to identify the actual job. 1038 begin 1039 Jid := Jid + 1; 1040 IO.Message 1041 (Builder, 1042 "register compilation " & Image (Id), True); 1043 1044 To_Run.Push 1045 (Job_Data'(Cmd, 1046 Id, OS_Lib.Invalid_Pid, 1047 Null_Unbounded_String, 1048 Null_Unbounded_String, 1049 Null_Unbounded_String, 1050 Null_Unbounded_String, 1051 Builder.Socket, J_Created)); 1052 1053 Send_Ack (Builder.Channel, Id); 1054 end Record_Job; 1055 1056 elsif Kind (Cmd) = FL then 1057 null; 1058 1059 elsif Kind (Cmd) = CU then 1060 Clean_Up_Request : begin 1061 1062 To_Run.Push 1063 (Job_Data'(Cmd, 1064 0, OS_Lib.Invalid_Pid, 1065 Null_Unbounded_String, 1066 Null_Unbounded_String, 1067 Null_Unbounded_String, 1068 Null_Unbounded_String, 1069 Builder.Socket, J_Created)); 1070 end Clean_Up_Request; 1071 1072 elsif Kind (Cmd) in EC | SI then 1073 -- No more compilation for this project. Send an 1074 -- Ack only if we are not handling a kill signal 1075 -- (receiving SI means that the socket has been 1076 -- detected to be closed). 1077 1078 Close_Builder (Builder, Ack => (Kind (Cmd) = EC)); 1079 1080 IO.Message 1081 (Builder, 1082 "End project : " 1083 & To_String (Builder.Project_Name)); 1084 1085 else 1086 raise Constraint_Error with "unexpected command " 1087 & Command_Kind'Image (Kind (Cmd)); 1088 end if; 1089 1090 exception 1091 when Socket_Error => 1092 -- The build master has probably been killed. We 1093 -- cannot communicate with it. Just close the channel. 1094 1095 Close_Builder (Builder, Ack => False); 1096 1097 IO.Message 1098 (Builder, 1099 "Interrupted project : " 1100 & To_String (Builder.Project_Name)); 1101 1102 when E : others => 1103 IO.Message 1104 (Builder, 1105 "Error: " 1106 & Exception_Information (E), Force => True); 1107 1108 -- In case of an exception, communication endded 1109 -- prematurately or some wrong command received, make 1110 -- sure we clean the slave state and we listen to new 1111 -- commands. Not doing that could make the slave 1112 -- unresponding. 1113 1114 Close_Builder (Builder, Ack => False); 1115 end; 1116 1117 -- The lock is released and freed if we have an EC command 1118 1119 Builders.Release (Builder); 1120 1121 else 1122 IO.Message 1123 ("build master not found, cannot handle request.", 1124 Is_Debug => True); 1125 end if; 1126 end if; 1127 end if; 1128 end loop Handle_Commands; 1129 1130 exception 1131 when E : others => 1132 IO.Message 1133 (Builder, "Unrecoverable error: Protocol_Handler.", Force => True); 1134 IO.Message (Builder, Symbolic_Traceback (E), Force => True); 1135 OS_Exit (1); 1136 end Wait_Requests; 1137 1138 ----------------- 1139 -- Execute_Job -- 1140 ----------------- 1141 1142 task body Execute_Job is 1143 1144 function Get_Driver 1145 (Builder : Build_Master; Language, Project : String) return String; 1146 -- Returns the compiler driver for the given language and the current 1147 -- target as retreived from the initial handshake context exchange. 1148 1149 function Get_Output_File (Builder : Build_Master) return String; 1150 -- Returns a unique output file 1151 1152 procedure Output_Compilation (Builder : Build_Master; File : String); 1153 -- Output compilation information 1154 1155 procedure Do_Compile (Job : in out Job_Data); 1156 -- Run a compilation job 1157 1158 procedure Do_Clean (Job : Job_Data); 1159 -- Run a clean job 1160 1161 package Drivers_Cache is new Containers.Indefinite_Hashed_Maps 1162 (String, String, 1163 Ada.Strings.Hash_Case_Insensitive, 1164 Ada.Strings.Equal_Case_Insensitive); 1165 1166 Cache : Drivers_Cache.Map; 1167 1168 ---------------- 1169 -- Get_Driver -- 1170 ---------------- 1171 1172 function Get_Driver 1173 (Builder : Build_Master; Language, Project : String) return String 1174 is 1175 procedure Look_Driver (Project_Name : String; Is_Config : Boolean); 1176 -- Set Driver with the found driver for the Language 1177 1178 Key : constant String := 1179 To_String (Builder.Target) & '+' & Language; 1180 Position : constant Drivers_Cache.Cursor := 1181 Cache.Find (Key); 1182 Compilers, Filters : Compiler_Lists.List; 1183 Requires_Comp : Boolean; 1184 Comp : Compiler_Access; 1185 Env : Environment; 1186 Success : Boolean; 1187 Driver : Unbounded_String := To_Unbounded_String (Key); 1188 1189 ----------------- 1190 -- Look_Driver -- 1191 ----------------- 1192 1193 procedure Look_Driver (Project_Name : String; Is_Config : Boolean) is 1194 Project_Node_Tree : GPR.Project_Node_Tree_Ref; 1195 Project_Node : Project_Node_Id := Empty_Project_Node; 1196 Project_Tree : Project_Tree_Ref; 1197 Project : Project_Id; 1198 begin 1199 Project_Node_Tree := new Project_Node_Tree_Data; 1200 GPR.Tree.Initialize (Project_Node_Tree); 1201 1202 GPR.Part.Parse 1203 (Project_Node_Tree, Project_Node, 1204 Project_Name, 1205 Errout_Handling => GPR.Part.Finalize_If_Error, 1206 Packages_To_Check => null, 1207 Is_Config_File => Is_Config, 1208 Target_Name => To_String (Builder.Target), 1209 Env => Env); 1210 1211 Project_Tree := new Project_Tree_Data; 1212 GPR.Initialize (Project_Tree); 1213 1214 Proc.Process 1215 (Project_Tree, Project, null, Success, 1216 Project_Node, Project_Node_Tree, Env); 1217 1218 if not Success then 1219 return; 1220 end if; 1221 1222 declare 1223 Pcks : Package_Table.Table_Ptr 1224 renames Project_Tree.Shared.Packages.Table; 1225 Pck : Package_Id := Project.Decl.Packages; 1226 begin 1227 Look_Compiler_Package : while Pck /= No_Package loop 1228 if Pcks (Pck).Decl /= No_Declarations 1229 and then Pcks (Pck).Name = Name_Compiler 1230 then 1231 -- Look for the Driver ("<language>") attribute 1232 1233 declare 1234 Id : Array_Id := Pcks (Pck).Decl.Arrays; 1235 begin 1236 while Id /= No_Array loop 1237 declare 1238 V : constant Array_Data := 1239 Project_Tree.Shared.Arrays.Table (Id); 1240 begin 1241 if V.Name = Name_Driver 1242 and then V.Value /= No_Array_Element 1243 then 1244 -- Check if element is for the given 1245 -- language, and if so return the 1246 -- corresponding value. 1247 1248 declare 1249 E : constant Array_Element := 1250 Project_Tree.Shared. 1251 Array_Elements.Table (V.Value); 1252 begin 1253 if Get_Name_String (E.Index) = 1254 To_Lower (Language) 1255 then 1256 Driver := To_Unbounded_String 1257 (Get_Name_String (E.Value.Value)); 1258 exit Look_Compiler_Package; 1259 end if; 1260 end; 1261 end if; 1262 end; 1263 1264 Id := Project_Tree.Shared.Arrays.Table (Id).Next; 1265 end loop; 1266 end; 1267 end if; 1268 1269 Pck := Pcks (Pck).Next; 1270 end loop Look_Compiler_Package; 1271 end; 1272 1273 exception 1274 -- Never propagate an exception, the driver won't be set anyway 1275 when others => 1276 null; 1277 end Look_Driver; 1278 1279 begin 1280 if Drivers_Cache.Has_Element (Position) then 1281 return Drivers_Cache.Element (Position); 1282 1283 else 1284 -- Generate the configuration project for this language and target 1285 1286 Parse_Config_Parameter 1287 (Base => Base, 1288 Config => Language, 1289 Compiler => Comp, 1290 Requires_Compiler => Requires_Comp); 1291 1292 if Requires_Comp then 1293 Filters.Append (Comp); 1294 else 1295 Compilers.Append (Comp); 1296 end if; 1297 1298 Complete_Command_Line_Compilers 1299 (Base, 1300 Selected_Targets_Set, 1301 Filters, 1302 Compilers); 1303 1304 -- Generate configuration project file 1305 1306 Generate_Configuration 1307 (Base, Compilers, "slave_tmp.cgpr", To_String (Builder.Target)); 1308 1309 GPR.Tree.Initialize (Env, GPR.Gprbuild_Flags); 1310 GPR.Initialize (GPR.No_Project_Tree); 1311 1312 GPR.Env.Initialize_Default_Project_Path 1313 (Env.Project_Path, Target_Name => To_String (Builder.Target)); 1314 1315 -- Parse it to find the driver for this language 1316 1317 Look_Driver ("slave_tmp.cgpr", Is_Config => True); 1318 Directories.Delete_File ("slave_tmp.cgpr"); 1319 1320 -- Language is not found in the knowledge base, check the project 1321 -- to see if there is a definition for the language. 1322 1323 if Driver = Key then 1324 Look_Driver (Project, Is_Config => False); 1325 1326 -- Ensure that we have a full-path name 1327 declare 1328 Exe : OS_Lib.String_Access := 1329 Locate_Exec_On_Path (To_String (Driver)); 1330 begin 1331 Driver := To_Unbounded_String (Exe.all); 1332 Free (Exe); 1333 end; 1334 end if; 1335 1336 -- Record this driver for the language and target into the cache 1337 1338 Cache.Insert (Key, To_String (Driver)); 1339 1340 -- Clean-up and free project structure 1341 1342 IO.Message 1343 (Builder, 1344 "driver for " & Language & " is : " & To_String (Driver), 1345 Is_Debug => True); 1346 1347 return To_String (Driver); 1348 end if; 1349 1350 exception 1351 when others => 1352 -- Be sure we never propagate an exception from this routine, in 1353 -- case of problem we just return the key, this will be used as an 1354 -- executable and will be reported to the master as a proper build 1355 -- failure. 1356 return Key; 1357 end Get_Driver; 1358 1359 --------------------- 1360 -- Get_Output_File -- 1361 --------------------- 1362 1363 function Get_Output_File (Builder : Build_Master) return String is 1364 Filename : constant String := "output.slave." & Image (Index); 1365 begin 1366 Index := Index + 1; 1367 return Compose (Work_Directory (Builder), Filename); 1368 end Get_Output_File; 1369 1370 ------------------------ 1371 -- Output_Compilation -- 1372 ------------------------ 1373 1374 procedure Output_Compilation 1375 (Builder : Build_Master; 1376 File : String) 1377 is 1378 1379 function Prefix return String; 1380 -- Returns a prefix for the display with a progress indication 1381 1382 ------------ 1383 -- Prefix -- 1384 ------------ 1385 1386 function Prefix return String is 1387 Active : constant String := Natural'Image (Running.Count + 1); 1388 Max : constant String := Natural'Image (Max_Processes); 1389 begin 1390 return "Compiling (" & Active (Active'First + 1 .. Active'Last) 1391 & '/' & Max (Max'First + 1 .. Max'Last) & ") : "; 1392 end Prefix; 1393 1394 RDL : constant Natural := Root_Directory'Length; 1395 1396 begin 1397 if Verbose then 1398 if File'Length > RDL 1399 and then File (File'First .. File'First + RDL - 1) 1400 = Root_Directory.all 1401 then 1402 IO.Message 1403 (Builder, 1404 Prefix & File (File'First + RDL + 1 .. File'Last)); 1405 else 1406 IO.Message (Builder, Prefix & File); 1407 end if; 1408 end if; 1409 end Output_Compilation; 1410 1411 ---------------- 1412 -- Do_Compile -- 1413 ---------------- 1414 1415 procedure Do_Compile (Job : in out Job_Data) is 1416 Builder : constant Build_Master := Builders.Get (Job.Build_Sock); 1417 Dir : constant String := Args (Job.Cmd)(2).all; 1418 List : Slice_Set; 1419 begin 1420 -- Enter a critical section to: 1421 -- - move to directory where the command is executed 1422 -- - execute the compilation command 1423 -- - register a new job and acknowledge 1424 -- - move back to working directory 1425 1426 IO.Message 1427 (Builder, "move to work directory " & Work_Directory (Builder), 1428 Is_Debug => True); 1429 1430 -- It is safe to change directory here without a lock as this is 1431 -- the only place where it happens and there is a single instance 1432 -- of this task. 1433 1434 Set_Directory (Work_Directory (Builder)); 1435 1436 -- Create/Move to object dir if any, note that if we 1437 -- have an absolute path name here it is because the 1438 -- Build_Root is probably not properly set. Try to fail 1439 -- gracefully to report a proper error message to the 1440 -- build master. 1441 -- 1442 -- If we have an absolute pathname, just start the 1443 -- process into the to directory. The output file will 1444 -- be created there and will be reported to the master. 1445 -- 1446 -- Note that the following block should never fail otherwise the 1447 -- process won't be started. Even if we know the compilation will 1448 -- fail we need to move forward as the result for this compilation 1449 -- is waited for by the build master. 1450 1451 begin 1452 if Dir /= "" then 1453 if not Is_Absolute_Path (Dir) 1454 and then not Is_Directory (Dir) 1455 then 1456 Create_Directory (Dir); 1457 end if; 1458 1459 IO.Message 1460 (Builder, "move to directory " & Dir, Is_Debug => True); 1461 1462 Set_Directory (Dir); 1463 end if; 1464 exception 1465 when others => 1466 IO.Message 1467 (Builder, "cannot move to object directory", 1468 Is_Debug => True); 1469 end; 1470 1471 Create (List, Args (Job.Cmd) (6).all, String'(1 => Opts_Sep)); 1472 1473 Execute : declare 1474 Project : constant String := 1475 Get_Arg (Builder, Args (Job.Cmd) (1).all); 1476 Language : constant String := Args (Job.Cmd) (3).all; 1477 Out_File : constant String := 1478 Get_Output_File (Builder); 1479 Obj_File : constant String := Args (Job.Cmd) (4).all; 1480 Dep_File : constant String := Args (Job.Cmd) (5).all; 1481 Env : constant String := 1482 Get_Arg (Builder, Args (Job.Cmd) (7).all); 1483 O : Argument_List := Get_Args (Builder, List); 1484 Pid : Process_Id; 1485 begin 1486 Output_Compilation (Builder, O (O'Last).all); 1487 1488 -- Set compiler environment 1489 1490 Set_Env (Env, Fail => False, Force => True); 1491 1492 -- It is critical to ensure that no IO is done while spawning 1493 -- the process. 1494 1495 Running.Start 1496 (Job => Job, 1497 Driver => Get_Driver (Builder, Language, Project), 1498 Options => O, 1499 Out_File => Out_File, 1500 Obj_File => Obj_File, 1501 Dep_File => Dep_File, 1502 Dep_Dir => (if Is_Absolute_Path (Dir) then "" else Dir), 1503 Pid => Pid); 1504 1505 IO.Message 1506 (Builder, " pid" & Integer'Image (Pid_To_Integer (Pid)), 1507 Is_Debug => True); 1508 IO.Message (Builder, " dep_file " & Dep_File, Is_Debug => True); 1509 IO.Message (Builder, " out_file " & Out_File, Is_Debug => True); 1510 IO.Message (Builder, " obj_file " & Obj_File, Is_Debug => True); 1511 1512 for K in O'Range loop 1513 Free (O (K)); 1514 end loop; 1515 end Execute; 1516 exception 1517 when E : others => 1518 IO.Message 1519 (Builder, 1520 "Error in Execute_Job: " & Symbolic_Traceback (E), 1521 Is_Debug => True); 1522 end Do_Compile; 1523 1524 -------------- 1525 -- Do_Clean -- 1526 -------------- 1527 1528 procedure Do_Clean (Job : Job_Data) is 1529 Builder : Build_Master := Builders.Get (Job.Build_Sock); 1530 begin 1531 Builder.Project_Name := 1532 To_Unbounded_String (Args (Job.Cmd)(1).all); 1533 1534 declare 1535 WD : constant String := Work_Directory (Builder); 1536 begin 1537 if Exists (WD) then 1538 IO.Message (Builder, "Delete " & WD); 1539 1540 -- Cannot delete if the process is still under 1541 -- the working directory, so move to the slave 1542 -- root directory. 1543 1544 Set_Directory (Root_Directory.all); 1545 1546 Delete_Tree (WD); 1547 end if; 1548 end; 1549 1550 Send_Ok (Builder.Channel); 1551 exception 1552 when E : others => 1553 IO.Message 1554 (Builder, 1555 "clean-up error " & Symbolic_Traceback (E), 1556 True); 1557 Send_Ko (Builder.Channel); 1558 end Do_Clean; 1559 1560 Job : Job_Data; 1561 begin 1562 loop 1563 -- Launch a new compilation only if the maximum of simultaneous 1564 -- process has not yet been reached. 1565 1566 Running.Wait_Slot; 1567 1568 To_Run.Pop (Job); 1569 1570 -- Only launch the job if the corresponding builder is still active. 1571 -- It could be the case that the builder has been interrupted 1572 -- (ctrl-c) and so removed from the set. 1573 1574 if Builders.Exists (Job.Build_Sock) then 1575 if Kind (Job.Cmd) = EX then 1576 Do_Compile (Job); 1577 else 1578 Do_Clean (Job); 1579 end if; 1580 end if; 1581 end loop; 1582 1583 exception 1584 when E : others => 1585 IO.Message ("Unrecoverable error: Execute_Job.", Force => True); 1586 IO.Message (Exception_Information (E), Force => True); 1587 OS_Exit (1); 1588 end Execute_Job; 1589 1590 ------------- 1591 -- Running -- 1592 ------------- 1593 1594 protected body Running is 1595 1596 procedure Register (Job : Job_Data) 1597 with Pre => Job.Stage = J_Running; 1598 -- Register a running Job 1599 1600 ----------- 1601 -- Count -- 1602 ----------- 1603 1604 function Count return Natural is 1605 begin 1606 return N_Count; 1607 end Count; 1608 1609 -------------------- 1610 -- Kill_Processes -- 1611 -------------------- 1612 1613 procedure Kill_Processes (Socket : Socket_Type) is 1614 To_Kill : Job_Data_Set.Set; 1615 C : Job_Data_Set.Cursor; 1616 begin 1617 -- First pass, record all job for the given builder 1618 1619 for Job of Set loop 1620 if Job.Build_Sock = Socket then 1621 To_Kill.Insert (Job); 1622 end if; 1623 end loop; 1624 1625 -- Second pass, kill processes and mark them as killed. Those jobs 1626 -- are interrupted and the builder removed, so there is no point to 1627 -- try to send back the compilation result to the master. 1628 -- 1629 -- This also ensure a faster termination of the build master. 1630 1631 for Job of To_Kill loop 1632 -- Mark job as killed into the set 1633 C := Set.Find (Job); 1634 Set (C).Stage := J_Killed; 1635 1636 Kill_Process_Tree (Job.Pid, Hard_Kill => True); 1637 IO.Message 1638 ("kill job" & Integer'Image (Pid_To_Integer (Job.Pid)), 1639 Is_Debug => True); 1640 end loop; 1641 end Kill_Processes; 1642 1643 -------------- 1644 -- Register -- 1645 -------------- 1646 1647 procedure Register (Job : Job_Data) is 1648 begin 1649 -- Let's ensure that while the job was prepared the builder was not 1650 -- hard-killed. If so we kill the process right now. The result won't 1651 -- be used anyway and we do not want it to linger here and possibly 1652 -- corrupt a new launched compilation for the same object file. 1653 -- 1654 -- Note that it is still inserted into the job set for the job exit 1655 -- status to be read. This ensure that the job is properly terminated 1656 -- by the OS (on Linux the process would stay as <defunct> for 1657 -- example). 1658 1659 if not Builders.Exists (Job.Build_Sock) then 1660 IO.Message 1661 ("kill job (missing builder)" 1662 & Integer'Image (Pid_To_Integer (Job.Pid)), 1663 Is_Debug => True); 1664 1665 Kill (Job.Pid, Hard_Kill => True); 1666 1667 Insert_Killed_Job : declare 1668 Killed_Job : Job_Data := Job; 1669 begin 1670 Killed_Job.Stage := J_Killed; 1671 Set.Insert (Killed_Job); 1672 end Insert_Killed_Job; 1673 1674 elsif Job.Pid = OS_Lib.Invalid_Pid then 1675 Dead.Insert (Job); 1676 else 1677 Set.Insert (Job); 1678 end if; 1679 1680 N_Count := N_Count + 1; 1681 end Register; 1682 1683 ----------- 1684 -- Start -- 1685 ----------- 1686 1687 procedure Start 1688 (Job : in out Job_Data; 1689 Driver : String; 1690 Options : Argument_List; 1691 Out_File : String; 1692 Obj_File : String; 1693 Dep_File : String; 1694 Dep_Dir : String; 1695 Pid : out Process_Id) is 1696 begin 1697 IO.Spawn (Driver, Options, Out_File, Pid); 1698 1699 Job.Pid := Pid; 1700 Job.Dep_File := To_Unbounded_String (Dep_File); 1701 Job.Obj_File := To_Unbounded_String (Obj_File); 1702 Job.Output := To_Unbounded_String (Out_File); 1703 Job.Dep_Dir := To_Unbounded_String (Dep_Dir); 1704 Job.Stage := J_Running; 1705 1706 -- Note that we want to register the job even if Pid is 1707 -- Invalid_Process. We want it to be recorded into the running 1708 -- process to be able to be retrieved by the Wait_Completion 1709 -- task and a proper NOK message to be sent to the builder. 1710 1711 Register (Job); 1712 end Start; 1713 1714 --------- 1715 -- Get -- 1716 --------- 1717 1718 procedure Get (Job : out Job_Data; Pid : Process_Id) is 1719 Pos : Job_Data_Set.Cursor; 1720 begin 1721 if Dead.Is_Empty then 1722 Job := No_Job; 1723 Job.Pid := Pid; 1724 Pos := Set.Find (Job); 1725 1726 -- Not that a job could be not found here because the Pid is one 1727 -- of gprconfig runned to generate a configuration file for a 1728 -- specific language. 1729 1730 if Job_Data_Set.Has_Element (Pos) then 1731 Job := Job_Data_Set.Element (Pos); 1732 Set.Delete (Job); 1733 N_Count := N_Count - 1; 1734 1735 -- If this is a job which has been killed (see Kill_Processes 1736 -- above), set to No_Job. We do this as the Wait_Completion 1737 -- task must not do anything with such a process (no need to 1738 -- send back answers as anyway the build master is not running 1739 -- anymore). 1740 1741 if Job.Stage = J_Killed then 1742 Job := No_Job; 1743 else 1744 Job.Stage := J_Terminated; 1745 end if; 1746 1747 else 1748 Job := No_Job; 1749 end if; 1750 1751 else 1752 Job := Dead.First_Element; 1753 Job.Stage := J_Terminated; 1754 Dead.Delete_First; 1755 N_Count := N_Count - 1; 1756 end if; 1757 end Get; 1758 1759 ------------- 1760 -- Set_Max -- 1761 ------------- 1762 1763 procedure Set_Max (Max : Positive) is 1764 begin 1765 Running.Max := Max; 1766 end Set_Max; 1767 1768 ---------- 1769 -- Wait -- 1770 ---------- 1771 1772 entry Wait when Count > 0 is 1773 begin 1774 null; 1775 end Wait; 1776 1777 --------------- 1778 -- Wait_Slot -- 1779 --------------- 1780 1781 entry Wait_Slot when Count < Max is 1782 begin 1783 null; 1784 end Wait_Slot; 1785 1786 end Running; 1787 1788 ------------ 1789 -- To_Run -- 1790 ------------ 1791 1792 protected body To_Run is 1793 1794 ---------- 1795 -- Push -- 1796 ---------- 1797 1798 procedure Push (Job : Job_Data) is 1799 J : Job_Data := Job; 1800 begin 1801 -- Always adds the clean-up job in front of the queue, this is 1802 -- friendler as we do not want the user to wait for all current 1803 -- compilation to terminate. 1804 1805 J.Stage := J_Waiting; 1806 1807 if Kind (Job.Cmd) = CU then 1808 Set.Prepend (J); 1809 else 1810 Set.Append (J); 1811 end if; 1812 end Push; 1813 1814 --------- 1815 -- Pop -- 1816 --------- 1817 1818 entry Pop (Job : out Job_Data) when not Set.Is_Empty is 1819 begin 1820 Job := Set.First_Element; 1821 Set.Delete_First; 1822 end Pop; 1823 1824 end To_Run; 1825 1826 --------------------- 1827 -- Wait_Completion -- 1828 --------------------- 1829 1830 task body Wait_Completion is 1831 1832 Pid : Process_Id; 1833 Success : Boolean; 1834 Job : Job_Data; 1835 Builder : Build_Master; 1836 1837 function Expand_Artifacts 1838 (Root : String; 1839 Base_Name : String; 1840 Patterns : String_Split.Slice_Set) return String_Set.Vector; 1841 -- Returns the set of artifacts for the Base_Name based on the patterns 1842 -- given by attribute Included_Artifact_Patterns. 1843 1844 ---------------------- 1845 -- Expand_Artifacts -- 1846 ---------------------- 1847 1848 function Expand_Artifacts 1849 (Root : String; 1850 Base_Name : String; 1851 Patterns : String_Split.Slice_Set) return String_Set.Vector 1852 is 1853 Count : constant Slice_Number := Slice_Count (Patterns); 1854 Result : String_Set.Vector; 1855 begin 1856 for K in 1 .. Count loop 1857 declare 1858 Item : constant String := String_Split.Slice (Patterns, K); 1859 Star : constant Natural := Fixed.Index (Item, "*"); 1860 Name : Unbounded_String; 1861 begin 1862 if Item'Length > 0 then 1863 -- No start to replace, this is a plain file-name 1864 1865 if Star = 0 then 1866 Name := To_Unbounded_String (Item); 1867 1868 else 1869 -- We have a star, replace it with the base name 1870 1871 Name := To_Unbounded_String 1872 (Item (Item'First .. Star - 1) 1873 & Base_Name & Item (Star + 1 .. Item'Last)); 1874 end if; 1875 1876 if Exists (Root & To_String (Name)) then 1877 Result.Append (Root & To_String (Name)); 1878 end if; 1879 end if; 1880 end; 1881 end loop; 1882 1883 return Result; 1884 end Expand_Artifacts; 1885 1886 begin 1887 loop 1888 -- Wait for a job to complete only if there is job running 1889 1890 Running.Wait; 1891 1892 Wait_Process (Pid, Success); 1893 1894 -- If a "dead" jobs is returned success is forced to False 1895 1896 if Pid = OS_Lib.Invalid_Pid then 1897 Success := False; 1898 end if; 1899 1900 Running.Get (Job, Pid); 1901 1902 -- Note that if there is not such element it could be because the 1903 -- build master has been killed before the end of the compilation. 1904 -- In this case an EC message is received by the slave and the 1905 -- Job_Set is clear. See Main_Loop in gprslave's body. 1906 1907 if Job /= No_Job then 1908 declare 1909 A : Argument_List_Access := Args (Job.Cmd); 1910 begin 1911 -- Free args 1912 1913 for K in A'Range loop 1914 Free (A (K)); 1915 end loop; 1916 1917 Free (A); 1918 end; 1919 1920 -- Now get the corresponding build master 1921 1922 Builder := Builders.Get (Job.Build_Sock); 1923 1924 if Is_Active_Build_Master (Builder) then 1925 Builders.Lock (Builder); 1926 1927 begin 1928 IO.Message 1929 (Builder, 1930 "job " & Image (Job.Id) & " terminated", 1931 Is_Debug => True); 1932 1933 declare 1934 DS : Character renames Directory_Separator; 1935 Dep_Dir : constant String := To_String (Job.Dep_Dir); 1936 Dep_File : constant String := To_String (Job.Dep_File); 1937 Obj_File : constant String := To_String (Job.Obj_File); 1938 Out_File : constant String := To_String (Job.Output); 1939 S : Boolean; 1940 begin 1941 if Exists (Out_File) then 1942 Send_Output (Builder.Channel, Out_File); 1943 end if; 1944 1945 OS_Lib.Delete_File (Out_File, S); 1946 1947 if Success then 1948 -- No dependency or object files to send back if the 1949 -- compilation was not successful. 1950 1951 declare 1952 R_Dir : constant String := 1953 Work_Directory (Builder) 1954 & (if Dep_Dir /= "" 1955 then DS & Dep_Dir else "") 1956 & DS; 1957 D_File : constant String := R_Dir & Dep_File; 1958 O_File : constant String := R_Dir & Obj_File; 1959 begin 1960 if Exists (D_File) 1961 and then Kind (D_File) = Ordinary_File 1962 then 1963 Send_File 1964 (Builder.Channel, D_File, Rewrite => True); 1965 end if; 1966 1967 if Exists (O_File) then 1968 Send_File 1969 (Builder.Channel, O_File, Rewrite => False); 1970 end if; 1971 1972 -- We also check for any artifacts based on the 1973 -- user's patterns if any. 1974 1975 for Artifact of 1976 Expand_Artifacts 1977 (Root => R_Dir, 1978 Base_Name => Base_Name (Obj_File), 1979 Patterns => 1980 Builder.Included_Artifact_Patterns) 1981 loop 1982 Send_File 1983 (Builder.Channel, Artifact, Rewrite => False); 1984 end loop; 1985 end; 1986 end if; 1987 end; 1988 1989 IO.Message 1990 (Builder, 1991 "compilation status " & Boolean'Image (Success), 1992 Is_Debug => True); 1993 1994 if Success then 1995 Send_Ok (Builder.Channel, Job.Id); 1996 else 1997 Send_Ko (Builder.Channel, Job.Id); 1998 end if; 1999 2000 Builders.Release (Builder); 2001 2002 exception 2003 when E : others => 2004 -- An exception can be raised if the builder master has 2005 -- been terminated. In this case the communication won't 2006 -- succeed. 2007 2008 IO.Message 2009 (Builder, 2010 "cannot send response to build master " 2011 & Exception_Information (E), 2012 Is_Debug => True); 2013 2014 -- Remove it from the list 2015 2016 Close_Builder (Builder, Ack => False); 2017 end; 2018 2019 else 2020 IO.Message 2021 ("build master not found, cannot send response.", 2022 Is_Debug => True); 2023 end if; 2024 2025 else 2026 -- This is not necessarily an error as we could get a Pid of a 2027 -- gprconfig run launched to generate a configuration file for a 2028 -- specific language. So we do not want to fail in this case. 2029 2030 IO.Message 2031 ("unknown job data for pid " 2032 & Integer'Image (Pid_To_Integer (Pid)), Is_Debug => True); 2033 end if; 2034 end loop; 2035 2036 exception 2037 when E : others => 2038 Put_Line ("Unrecoverable error: Wait_Completion."); 2039 Put_Line (Symbolic_Traceback (E)); 2040 OS_Exit (1); 2041 end Wait_Completion; 2042 2043 --------------------- 2044 -- Wait_For_Master -- 2045 --------------------- 2046 2047 procedure Wait_For_Master is 2048 use Stamps; 2049 2050 procedure Sync_Gpr (Builder : in out Build_Master); 2051 2052 -------------- 2053 -- Sync_Gpr -- 2054 -------------- 2055 2056 procedure Sync_Gpr (Builder : in out Build_Master) is 2057 2058 use type Containers.Count_Type; 2059 2060 package Files is new Containers.Indefinite_Ordered_Sets (String); 2061 2062 procedure Delete_Files (Except : Files.Set); 2063 -- Delete all files in the current working tree except those in 2064 -- Except set. 2065 2066 WD : constant String := Work_Directory (Builder); 2067 2068 ------------------ 2069 -- Delete_Files -- 2070 ------------------ 2071 2072 procedure Delete_Files (Except : Files.Set) is 2073 2074 procedure Process (Path : String); 2075 -- Search recursively the Path 2076 2077 procedure Process (Path : String) is 2078 2079 procedure Check (File : Directory_Entry_Type); 2080 -- Remove this file if not part of Except set 2081 2082 ----------- 2083 -- Check -- 2084 ----------- 2085 2086 procedure Check (File : Directory_Entry_Type) is 2087 S_Name : constant String := Simple_Name (File); 2088 Entry_Name : constant String := 2089 Path & Directory_Separator & S_Name; 2090 begin 2091 if Kind (File) = Directory then 2092 if S_Name not in "." | ".." 2093 and then not Is_Symbolic_Link (Entry_Name) 2094 then 2095 Process (Entry_Name); 2096 end if; 2097 2098 else 2099 if not Except.Contains (Entry_Name) then 2100 IO.Message 2101 (Builder, 2102 "delete excluded '" & Entry_Name & ''', 2103 Is_Debug => True); 2104 2105 Delete_File (Entry_Name); 2106 end if; 2107 end if; 2108 end Check; 2109 2110 begin 2111 Search 2112 (Directory => Path, 2113 Pattern => "*", 2114 Filter => (Special_File => False, others => True), 2115 Process => Check'Access); 2116 end Process; 2117 2118 begin 2119 Process (WD); 2120 end Delete_Files; 2121 2122 Total_File : Natural := 0; 2123 Total_Transferred : Natural := 0; 2124 In_Master : Files.Set; 2125 2126 begin 2127 Check_Time_Stamps : loop 2128 declare 2129 To_Sync : File_Data_Set.Vector; 2130 Cmd : Command; 2131 K : Positive := 1; 2132 Message : Unbounded_String; 2133 begin 2134 Cmd := Get_Command (Builder.Channel); 2135 2136 if Debug then 2137 Message := To_Unbounded_String 2138 ("command: " & Command_Kind'Image (Kind (Cmd))); 2139 2140 if Args (Cmd) /= null then 2141 for K in Args (Cmd)'Range loop 2142 Append (Message, ", " & Args (Cmd) (K).all); 2143 end loop; 2144 end if; 2145 2146 IO.Message (To_String (Message), Is_Debug => True); 2147 end if; 2148 2149 if Kind (Cmd) = TS then 2150 -- Check all files in the argument of the command. This is a 2151 -- list of couple (filename and time stamp). 2152 2153 Check_All_Files : loop 2154 Total_File := Total_File + 1; 2155 2156 declare 2157 Path_Name : constant String := Args (Cmd) (K).all; 2158 Full_Path : constant String := 2159 WD & Directory_Separator & Path_Name; 2160 TS : constant Time_Stamp_Type := 2161 Time_Stamp_Type 2162 (Args (Cmd) (K + 1).all); 2163 File_Stamp : Time_Stamp_Type; 2164 Exists : Boolean; 2165 begin 2166 if Directories.Exists (Full_Path) then 2167 File_Stamp := 2168 To_Time_Stamp 2169 (Modification_Time (Full_Path) 2170 - Duration (Time_Zones.UTC_Time_Offset) * 60.0); 2171 Exists := True; 2172 else 2173 Exists := False; 2174 end if; 2175 2176 In_Master.Insert (Full_Path); 2177 2178 if not Exists or else File_Stamp /= TS then 2179 To_Sync.Append 2180 (File_Data' 2181 (To_Unbounded_String (Path_Name), TS)); 2182 end if; 2183 end; 2184 2185 K := K + 2; 2186 exit Check_All_Files when K > Args (Cmd)'Length; 2187 end loop Check_All_Files; 2188 2189 -- If all files are up-to-data 2190 2191 if To_Sync.Length = 0 then 2192 Send_Ok (Builder.Channel); 2193 2194 else 2195 -- Some files are to be synchronized, send the list of 2196 -- names back to the master. 2197 2198 Send_Ko (Builder.Channel, To_Sync); 2199 2200 -- We then receive the files contents in the same order 2201 2202 Get_RAW_Data : declare 2203 Max : constant String := 2204 Containers.Count_Type'Image (To_Sync.Length); 2205 N : Natural := 0; 2206 begin 2207 for W of To_Sync loop 2208 declare 2209 Full_Path : constant String := 2210 WD & Directory_Separator 2211 & To_String (W.Path_Name); 2212 begin 2213 Create_Path (Containing_Directory (Full_Path)); 2214 2215 Get_RAW_File_Content 2216 (Builder.Channel, Full_Path, W.Timestamp); 2217 end; 2218 2219 N := N + 1; 2220 2221 if N mod 100 = 0 then 2222 IO.Message 2223 (Builder, 2224 "File transfered" 2225 & Natural'Image (N) & "/" & Max); 2226 end if; 2227 end loop; 2228 end Get_RAW_Data; 2229 2230 Total_Transferred := 2231 Total_Transferred + Natural (To_Sync.Length); 2232 end if; 2233 2234 elsif Kind (Cmd) = ES then 2235 -- Delete all files not part of the list sent by the master. 2236 -- This is needed to remove files in previous build removed 2237 -- since then on the master. Again we need to do that as we 2238 -- can't let around unnedded specs or bodies. 2239 2240 Delete_Files (Except => In_Master); 2241 2242 exit Check_Time_Stamps; 2243 2244 elsif Kind (Cmd) in EC | SI then 2245 -- Cannot communicate with build master anymore, we then 2246 -- receive an end-of-compilation. Exit now. Note that we do 2247 -- not need to remove the builder from the list as it is not 2248 -- yet registered. 2249 2250 Close_Builder (Builder, Ack => (Kind (Cmd) = EC)); 2251 Builder.Socket := No_Socket; 2252 2253 exit Check_Time_Stamps; 2254 end if; 2255 end; 2256 end loop Check_Time_Stamps; 2257 2258 IO.Message (Builder, "Files total:" & Natural'Image (Total_File)); 2259 IO.Message 2260 (Builder, " transferred :" & Natural'Image (Total_Transferred)); 2261 2262 exception 2263 when E : others => 2264 IO.Message (Builder, "Lost connection with " & Image (Address)); 2265 IO.Message (Builder, Exception_Information (E), Is_Debug => True); 2266 Close (Builder.Channel); 2267 Close_Socket (Builder.Socket); 2268 Builder.Socket := No_Socket; 2269 end Sync_Gpr; 2270 2271 Builder : Build_Master; 2272 Clock_Status : Boolean; 2273 2274 begin 2275 -- Wait for a connection 2276 2277 Wait_Incoming_Master : loop 2278 begin 2279 Accept_Socket (Server, Builder.Socket, Address); 2280 exit Wait_Incoming_Master; 2281 exception 2282 when E : Socket_Error => 2283 if Resolve_Exception (E) /= Interrupted_System_Call then 2284 raise; 2285 end if; 2286 end; 2287 end loop Wait_Incoming_Master; 2288 2289 Builder.Channel := Create (Builder.Socket); 2290 2291 -- We must call explicitely Initialize here to ensure that the Builder 2292 -- object Status access will be changed for this new builder. 2293 2294 Controlled_Build_Master.Initialize (Builder); 2295 2296 -- Then initialize the new builder Id 2297 2298 Builders.Initialize (Builder); 2299 2300 IO.Message (Builder, "Connecting with " & Image (Address)); 2301 2302 -- Initial handshake 2303 2304 declare 2305 Master_Timestamp : Time_Stamp_Type; 2306 Version : Unbounded_String; 2307 Hash : Unbounded_String; 2308 Patterns : Unbounded_String; 2309 Is_Ping : Boolean; 2310 begin 2311 Get_Context 2312 (Builder.Channel, Builder.Target, 2313 Builder.Project_Name, Builder.Build_Env, Builder.Sync, 2314 Master_Timestamp, Version, Hash, Patterns, Is_Ping); 2315 2316 -- Set included artifact patterns 2317 2318 String_Split.Create 2319 (Builder.Included_Artifact_Patterns, 2320 To_String (Patterns), Separators => "|"); 2321 2322 if Is_Ping then 2323 Send_Ping_Response 2324 (Builder.Channel, 2325 GPR_Version.Gpr_Version_String, 2326 UTC_Time, 2327 Gprslave.Hash.all); 2328 2329 IO.Message (Builder, "Ping response to " & Image (Address)); 2330 Close (Builder.Channel); 2331 Close_Socket (Builder.Socket); 2332 Builder.Socket := No_Socket; 2333 return; 2334 end if; 2335 2336 Clock_Status := Check_Diff (Master_Timestamp, UTC_Time); 2337 2338 if To_String (Version) /= GPR_Version.Gpr_Version_String then 2339 IO.Message 2340 (Builder, "Reject non compatible build for " 2341 & To_String (Builder.Project_Name)); 2342 Send_Ko (Builder.Channel); 2343 return; 2344 end if; 2345 2346 if Builders.Working_Dir_Exists (Work_Directory (Builder)) then 2347 IO.Message 2348 (Builder, "Cannot use the same build environment for " 2349 & To_String (Builder.Project_Name)); 2350 Send_Ko 2351 (Builder.Channel, 2352 "build environment " 2353 & To_String (Builder.Build_Env) & " already in use"); 2354 return; 2355 end if; 2356 2357 -- If a hash has been specified, it must match the one from the 2358 -- master. 2359 2360 if Gprslave.Hash /= null 2361 and then Gprslave.Hash.all /= To_String (Hash) 2362 then 2363 IO.Message 2364 (Builder, "hash does not match " 2365 & To_String (Builder.Project_Name)); 2366 Send_Ko 2367 (Builder.Channel, 2368 "hash does not match, slave is " & Gprslave.Hash.all); 2369 return; 2370 end if; 2371 2372 exception 2373 when E : others => 2374 IO.Message (Builder, Exception_Information (E)); 2375 -- Do not try to go further, just close the socket 2376 begin 2377 Close (Builder.Channel); 2378 Close_Socket (Builder.Socket); 2379 Builder.Socket := No_Socket; 2380 exception 2381 when others => 2382 null; 2383 end; 2384 return; 2385 end; 2386 2387 Get_Targets_Set 2388 (Base, To_String (Builder.Target), Selected_Targets_Set); 2389 2390 IO.Message 2391 (Builder, "Handling project : " & To_String (Builder.Project_Name)); 2392 IO.Message (Builder, "Compiling for : " & To_String (Builder.Target)); 2393 2394 -- Create slave environment if needed 2395 2396 if not Exists (Work_Directory (Builder)) then 2397 IO.Message 2398 (Builder, 2399 "create build environment directory: " 2400 & Work_Directory (Builder), Is_Debug => True); 2401 2402 Create_Path (Work_Directory (Builder)); 2403 end if; 2404 2405 -- Configure slave, note that this does not need to be into the critical 2406 -- section has the builder is not yet known in the system. At this point 2407 -- no compilation can be received for this slave anyway. 2408 2409 Set_Rewrite_WD 2410 (Builder.Channel, Path => Work_Directory (Builder)); 2411 2412 -- For Ada compilers, rewrite the root directory 2413 2414 if Compiler_Path = null then 2415 IO.Message (Builder, "compiler path is null.", Is_Debug => True); 2416 else 2417 IO.Message 2418 (Builder, 2419 "compiler path is : " 2420 & Containing_Directory (Containing_Directory (Compiler_Path.all)), 2421 Is_Debug => True); 2422 end if; 2423 2424 if Compiler_Path /= null then 2425 Set_Rewrite_CD 2426 (Builder.Channel, 2427 Path => Containing_Directory 2428 (Containing_Directory (Compiler_Path.all))); 2429 end if; 2430 2431 -- It is safe to write to this builder outside of a lock here as this 2432 -- builder is not yet registered into the slave. 2433 2434 Send_Slave_Config 2435 (Builder.Channel, Max_Processes, 2436 Compose (Root_Directory.all, To_String (Builder.Build_Env)), 2437 Clock_Status); 2438 2439 -- If we are using the Gpr synchronisation, it is time to do it here. 2440 -- Note that we want to avoid the rewriting rules below that are 2441 -- requiring some CPU cycles not needed at this stage. 2442 2443 if Builder.Sync then 2444 -- Move to projet directory 2445 Sync_Gpr (Builder); 2446 end if; 2447 2448 -- Register the new builder 2449 2450 if Builder.Socket /= No_Socket then 2451 Builders.Insert (Builder); 2452 end if; 2453 2454 exception 2455 when E : others => 2456 IO.Message 2457 (Builder, "Unrecoverable error: Wait_For_Master.", Force => True); 2458 IO.Message (Builder, Symbolic_Traceback (E), Force => True); 2459 OS_Exit (1); 2460 end Wait_For_Master; 2461 2462 -------------------- 2463 -- Work_Directory -- 2464 -------------------- 2465 2466 function Work_Directory (Builder : Build_Master) return String is 2467 begin 2468 return Compose 2469 (Compose (Root_Directory.all, To_String (Builder.Build_Env)), 2470 To_String (Builder.Project_Name)); 2471 end Work_Directory; 2472 2473begin 2474 Parse_Command_Line; 2475 2476 -- Initialize the project support 2477 2478 Snames.Initialize; 2479 2480 Parse_Knowledge_Base (Base, Default_Knowledge_Base_Directory); 2481 2482 Activate_Symbolic_Traceback; 2483 2484 -- Always create the lib/object directories on the slave, this is needed 2485 -- when parsing a projet file to retreive a specific driver. 2486 2487 Opt.Setup_Projects := True; 2488 2489 -- Setup the response handlers 2490 2491 if Max_Responses < 1 then 2492 Max_Responses := 1; 2493 elsif Max_Responses > Max_Processes then 2494 Max_Responses := Max_Processes; 2495 end if; 2496 2497 Response_Handlers := new Response_Handler_Set (1 .. Max_Responses); 2498 2499 -- Wait for a gprbuild connection on any addresses 2500 2501 Address.Addr := Any_Inet_Addr; 2502 Address.Port := Port_Type (Port); 2503 2504 Create_Socket (Server); 2505 2506 Set_Socket_Option (Server, Socket_Level, (Reuse_Address, True)); 2507 2508 Bind_Socket (Server, Address); 2509 2510 if Port = 0 then 2511 Address := Get_Socket_Name (Server); 2512 end if; 2513 2514 Put_Line 2515 ("GPRSLAVE " & GPR_Version.Gpr_Version_String & " on " & Host_Name 2516 & ":" & Image (Long_Integer (Address.Port))); 2517 Put_Line (" max processes :" & Integer'Image (Max_Processes)); 2518 Put_Line (" max responses :" & Integer'Image (Max_Responses)); 2519 2520 -- Initialize the host key used to create unique pid 2521 2522 Slave_Id := Get_Slave_Id; 2523 2524 IO.Message ("slave id " & Image (Slave_Id), Is_Debug => True); 2525 2526 Listen_Socket (Server); 2527 2528 Main_Loop : loop 2529 Wait_For_Master; 2530 end loop Main_Loop; 2531 2532exception 2533 when E : others => 2534 IO.Message ("Unrecoverable error: GprSlave.", Force => True); 2535 IO.Message (Symbolic_Traceback (E), Force => True); 2536 OS_Exit (1); 2537end Gprslave; 2538