libgpr_22.0.0_30e39dcc/src/gprslave.adb

------------------------------------------------------------------------------
--                                                                          --
--                             GPR TECHNOLOGY                               --
--                                                                          --
--                     Copyright (C) 2012-2021, AdaCore                     --
--                                                                          --
-- This is  free  software;  you can redistribute it and/or modify it under --
-- terms of the  GNU  General Public License as published by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  This software is distributed in the hope  that it will be useful, --
-- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public --
-- License for more details.  You should have received  a copy of the  GNU  --
-- General Public License distributed with GNAT; see file  COPYING. If not, --
-- see <http://www.gnu.org/licenses/>.                                      --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Calendar.Formatting;
with Ada.Characters.Handling;               use Ada.Characters.Handling;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Containers.Indefinite_Vectors;
with Ada.Containers.Ordered_Sets;
with Ada.Containers.Vectors;
with Ada.Directories;                       use Ada.Directories;
with Ada.Exceptions;                        use Ada.Exceptions;
with Ada.Finalization;                      use Ada.Finalization;
with Ada.Strings.Equal_Case_Insensitive;
with Ada.Strings.Fixed;                     use Ada.Strings;
with Ada.Strings.Hash_Case_Insensitive;
with Ada.Strings.Unbounded;                 use Ada.Strings.Unbounded;
with Ada.Text_IO;                           use Ada.Text_IO;
with Ada.Unchecked_Deallocation;
with System.Multiprocessors;                use System;

with GNAT.Command_Line;         use GNAT;
with GNAT.CRC32;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.Exception_Traces;
with GNAT.OS_Lib;             use GNAT.OS_Lib;
with GNAT.Sockets;            use GNAT.Sockets;
with GNAT.String_Split;       use GNAT.String_Split;
with GNAT.Strings;
with GNAT.Traceback.Symbolic; use GNAT.Traceback;
                              use GNAT.Traceback.Symbolic;

with GPR.Compilation;          use GPR.Compilation;
with GPR.Compilation.Protocol; use GPR.Compilation.Protocol;
with GPR.Compilation.Sync;     use GPR.Compilation.Sync;
with GPR.Util;                 use GPR.Util;
with GPR.Version;

with GPR;                      use GPR;
with GPR.Env;
with GPR.Knowledge;            use GPR.Knowledge;
with GPR.Names;                use GPR.Names;
with GPR.Opt;                  use GPR.Opt;
with GPR.Part;                 use GPR.Part;
with GPR.Proc;
with GPR.Snames;               use GPR.Snames;
with GPR.Tree;                 use GPR.Tree;

procedure Gprslave is

   use Ada;

   type UID is mod 9999;

   --  The Status is shared by the same build master object. It first has a
   --  reference counter to free the memory associated with this status and
   --  a boolean used a a mutex to lock/unlock the object to allow proper
   --  concurrent access.

   type Data is record
      Channel                    : Communication_Channel;
      --  Communication with build master
      Project_Name               : Unbounded_String;
      Target                     : Unbounded_String;
      Build_Env                  : Unbounded_String;
      Included_Artifact_Patterns : String_Split.Slice_Set;
      Id                         : UID;
      Locked                     : Boolean := False;
      Count                      : Natural := 0;
   end record;

   type Shared_Data is access Data;

   --  Data for a build master

   type Build_Master is new Finalization.Controlled with record
      Sync : Boolean;
      D    : Shared_Data;
   end record;

   overriding procedure Initialize (Builder : in out Build_Master);
   overriding procedure Adjust     (Builder : in out Build_Master);
   overriding procedure Finalize   (Builder : in out Build_Master);

   --  Controlled_Build_Master is to ensure that the Build_Master controlled
   --  object can be used concurrently.

   protected Controlled_Build_Master is
      procedure Initialize (Builder : in out Build_Master);
      procedure Adjust     (Builder : in out Build_Master);
      procedure Finalize   (Builder : in out Build_Master);
   end Controlled_Build_Master;

   function Sock (Builder : Build_Master'Class) return Socket_Type is
     (Protocol.Sock (Builder.D.Channel));

   package Builder is

      function "<" (B1, B2 : Build_Master) return Boolean is
        (To_C (Sock (B1)) < To_C (Sock (B2)));

      function "=" (B1, B2 : Build_Master) return Boolean is
        (Sock (B1) = Sock (B2));

      package Set is new Containers.Ordered_Sets (Build_Master);

   end Builder;

   package Builder_Set renames Builder.Set;

   --  Representation of a job data

   type Stages is
     (J_None, J_Created, J_Waiting, J_Running, J_Terminated, J_Killed);

   type Job_Data is record
      Cmd        : Command;
      Id         : Remote_Id := -1; -- job id must be uniq across all slaves
      Pid        : Process_Id := OS_Lib.Invalid_Pid; -- the OS process id
      Dep_Dir    : Unbounded_String;
      Dep_File   : Unbounded_String;
      Obj_File   : Unbounded_String;
      Output     : Unbounded_String;
      Build_Sock : Socket_Type; -- key used to get the corresponding builder
      Stage      : Stages := J_None;
   end record with Dynamic_Predicate =>
     (case Job_Data.Stage is
         when J_None =>
           Job_Data.Id = -1,

         when J_Created | J_Waiting =>
           Job_Data.Pid = OS_Lib.Invalid_Pid
           and then Kind (Job_Data.Cmd) in EX | CU
           and then Job_Data.Build_Sock /= No_Socket,

         when J_Running | J_Terminated | J_Killed =>
           Job_Data.Pid /= OS_Lib.Invalid_Pid
           and then Kind (Job_Data.Cmd) in EX | CU
           and then Job_Data.Build_Sock /= No_Socket);

   function "<" (J1, J2 : Job_Data) return Boolean is
     (Pid_To_Integer (J1.Pid) < Pid_To_Integer (J2.Pid));

   function "=" (J1, J2 : Job_Data) return Boolean is
     (Pid_To_Integer (J1.Pid) = Pid_To_Integer (J2.Pid));

   No_Job : constant Job_Data :=
              (Id     => -1,
               Pid    => OS_Lib.Invalid_Pid,
               Stage  => J_None,
               others => <>);

   package Job_Data_Set is new Containers.Ordered_Sets (Job_Data);

   package To_Run_Set is new Containers.Vectors (Positive, Job_Data);

   function Get_Arg
     (Builder : Build_Master; Value : String) return String with Inline;
   --  Returns Value with possible translation of the local repositories

   function Get_Args
     (Builder : Build_Master; Slices : Slice_Set) return Argument_List;
   --  Returns an Argument_List corresponding to the Slice_Set

   function Image (Value : Long_Integer) return String;
   --  Return Value string representation without the leading space

   function Work_Directory (Builder : Build_Master) return String;
   --  Directory where compilation are to be done, this is the directory named
   --  after the project under the Root_Directory.

   procedure Parse_Command_Line;
   --  Parse the command line options, set variables below accordingly

   function Get_Slave_Id return Remote_Id;

   function Is_Active_Build_Master (Builder : Build_Master) return Boolean is
     (Builder.D /= null
      and then Builder.D.Project_Name /= Null_Unbounded_String);

   procedure Close_Builder (Builder : in out Build_Master; Ack : Boolean);
   --  Close the channel and socket and remove the builder from the slave. This
   --  procedure never fails. Send a OK message if Ack is True.

   procedure Display
     (Builder  : Build_Master;
      Str      : String;
      Is_Debug : Boolean := False;
      Force    : Boolean := False) with Inline;
   procedure Display
     (Str      : String;
      Is_Debug : Boolean := False;
      Force    : Boolean := False) with Inline;
   --  Display messages if needed (depending on the current mode)

   procedure Activate_Symbolic_Traceback;
   --  Activate symbolic trace-back

   --
   --  Belows are the main objects which handle the concurrent requests
   --

   procedure Wait_For_Master;
   --  Wait for a build master to connect, initialize the global communication
   --  channel. This procedure is run under the environment task. Send the
   --  slave config to the build master. Either a builder object is created and
   --  inserted into the Builders protected object or the builder is rejected
   --  because of inconsistent state:
   --
   --  1. the builder and the slave are not using the same compiler.
   --  2. the slave is already handling compilation for this project
   --     environment.

   task Wait_Requests;
   --  Waiting for incoming requests from the masters, take corresponding
   --  actions. Three actions are handled here:
   --
   --  1. EX - execute a compilation
   --     A compilation request is inserted into To_Run protected object.
   --
   --  2. CU - execute a clean-up
   --     A clean-up request is inserted into To_Run protected object.
   --
   --  3. EC - stop execution for the given builder

   task Execute_Job;
   --  Task running a maximum of Max_Process compilation simultaneously. These
   --  jobs are taken from the To_Run protected object (a FIFO list).
   --
   --  Jobs taken from To_Run protected object are removed, executed
   --  asynchronously and inserted into the Running protected object with
   --  the corresponding process Id and builder.
   --
   --  IMPORTANT NOTE : this is the only task that can change the working
   --  directory (Set_Directory for example). This makes locking circuitry
   --  lighter and more efficient.

   task type Wait_Completion;
   --  Waiting for completion of compilation jobs. The Pid is retreived with
   --  the corresponding builder, then it sends back the response to the build
   --  masters. The response is OK or NOK depending on compilation result. If
   --  OK the auxiliaries files (.ali, .o) are sent back to the build master.
   --
   --  This is the only task with multiple instance. As sending back resulting
   --  objects and ALI files can take some time haaving multiple instance
   --  permit to send results to different builders simultaneously.

   protected Builders is

      --  Protected builders data set (used by environment task and the
      --  Protocol_Handler).
      --
      --  The list of builder, one for each build master. Inserted here when a
      --  compilation starts and removed when an end-of-compilation message is
      --  received or a master is interrupted.

      procedure Insert (Builder : Build_Master);
      --  Add Builder into the set

      procedure Remove (Builder : in out Build_Master);
      --  Remove Builder from the set

      function Get (Socket : Socket_Type) return Build_Master;
      --  Get the builder using Socket

      function Exists (Socket : Socket_Type) return Boolean;
      --  Returns True if the build master corresponding to socket is found.
      --  False otherwise.

      entry Get_Socket_Set (Socket_Set : out Socket_Set_Type);
      --  Get a socket set for all builders

      procedure Initialize (Builder : in out Build_Master);
      --  Set the UID for this build master. This Id is only used in log
      --  message to identify a specific build.

      function Working_Dir_Exists (Directory : String) return Boolean;
      --  Returns True if Directory is already used by a registered build
      --  master. This is to ensure that a unique build will happen in a
      --  given directory.

      entry Lock (Builder : in out Build_Master);
      --  Lock builder against concurrent use, must be released

      procedure Release (Builder : in out Build_Master);
      --  Release builder locked with entry above

   private

      entry Try_Lock (Builder : in out Build_Master);
      --  The lock is already taken, the tasks are queued here to wait for the
      --  builder to be released.

      Current_Id : UID := 0;
      Builders   : Builder_Set.Set;
      To_Check   : Natural := 0; -- number of task to let go through Try_Lock
   end Builders;

   protected To_Run is

      --  Queue of Job to run, A FIFO list of jobs comming from all registered
      --  builders.

      procedure Push (Job : Job_Data)
        with Pre => Job.Stage = J_Created;

      entry Pop (Job : out Job_Data)
        with Post => Job.Stage = J_Waiting;

   private
      Set : To_Run_Set.Vector;
   end To_Run;

   protected Running is

      --  Set of running jobs. Removed when the compilation terminates or when
      --  killed because of a builder is interrupted.

      procedure Start
        (Job      : in out Job_Data;
         Driver   : String;
         Options  : Argument_List;
         Out_File : String;
         Obj_File : String;
         Dep_File : String;
         Dep_Dir  : String;
         Pid      : out Process_Id)
        with Pre => Job.Stage = J_Waiting, Post => Job.Stage = J_Running;
      --  Start and register a new running job

      procedure Get (Job : out Job_Data; Pid : Process_Id)
        with Post => Job = No_Job or else Job.Stage = J_Terminated;
      --  Get Job having the given Pid

      procedure Set_Max (Max : Positive);
      --  Set the maximum running processes simultaneously

      entry Wait_Slot;
      --  Wait for a running slot to be available

      entry Wait;
      --  Wait for at least one running process

      procedure Kill_Processes (Socket : Socket_Type);
      --  Kill all processes whose builder is registered with Socket. This
      --  is used when a builder is interrupted to kill all corresponding
      --  processes.

      function Count return Natural;
      --  Number of job running

   private
      Set     : Job_Data_Set.Set;
      Dead    : Job_Data_Set.Set; -- job which failed to start
      N_Count : Natural := 0;     -- actual number of running process
      Max     : Natural := 0;
   end Running;

   --  Ensure that all IO are serialized, especially the spawn of process which
   --  must never happen during other IO. This is needed as the spawned process
   --  will inherit the standard IO descriptors.

   protected IO is

      procedure Message
        (Builder  : Build_Master;
         Str      : String;
         Is_Debug : Boolean := False);
      procedure Message
        (Str      : String;
         Is_Debug : Boolean := False);
      --  Display a message (in verbose mode) and adds a leading timestamp.
      --  Also display the message in debug mode if Is_Debug is set.

      procedure Spawn
        (Driver   : String;
         Options  : Argument_List;
         Out_File : String;
         Pid      : out Process_Id);

   end IO;

   Compiler_Path : constant OS_Lib.String_Access :=
                     Locate_Exec_On_Path ("gprls");

   Slave_Id : Remote_Id;
   --  Host Id used to compose a unique job id across all running slaves

   --  Command line parameters statuses

   Port           : aliased Integer;
   Max_Processes  : aliased Integer;
   Max_Responses  : aliased Integer;
   Help           : aliased Boolean := False;
   Verbose        : aliased Boolean := False;
   Debug          : aliased Boolean := False;
   Root_Directory : aliased GNAT.Strings.String_Access :=
                       new String'(Get_Current_Dir);
   --  Root directoty for the gprslave environment. All projects sources and
   --  compilations are done under this directory.
   Hash           : aliased GNAT.Strings.String_Access;

   --  Running instances statuses

   Address : Sock_Addr_Type;
   Server  : Socket_Type;
   Index   : Long_Integer := 0;

   --  Knowledge base

   Base                 : Knowledge_Base;
   Selected_Targets_Set : Targets_Set_Id;

   --  Handle response

   type Response_Handler_Set is array (Positive range <>) of Wait_Completion;
   type Response_Handler_Set_Access is access Response_Handler_Set;

   Response_Handlers : Response_Handler_Set_Access with Unreferenced;
   --  Sending response to a build master may take some time as the object file
   --  is sent back over the socket with the corresponding dependency file.

   ------------
   -- Adjust --
   ------------

   overriding procedure Adjust (Builder : in out Build_Master) is
   begin
      Controlled_Build_Master.Adjust (Builder);
   end Adjust;

   ---------------------------------
   -- Activate_Symbolic_Traceback --
   ---------------------------------

   procedure Activate_Symbolic_Traceback is
   begin
      Exception_Traces.Trace_On (Exception_Traces.Unhandled_Raise);
      Exception_Traces.Set_Trace_Decorator
        (Traceback.Symbolic.Symbolic_Traceback'Access);
   end Activate_Symbolic_Traceback;

   --------------
   -- Builders --
   --------------

   protected body Builders is

      ------------
      -- Exists --
      ------------

      function Exists (Socket : Socket_Type) return Boolean is
         Builder : Build_Master;
      begin
         Builder.D.Channel := Protocol.Create (Socket, Virtual => True);
         return Builder_Set.Has_Element (Builders.Find (Builder));
      end Exists;

      ---------
      -- Get --
      ---------

      function Get (Socket : Socket_Type) return Build_Master is
         Builder : Build_Master;
         Pos     : Builder_Set.Cursor;
      begin
         Builder.D.Channel := Protocol.Create (Socket, Virtual => True);

         Pos := Builders.Find (Builder);

         if Builder_Set.Has_Element (Pos) then
            Builder := Builder_Set.Element (Pos);
         end if;

         return Builder;
      end Get;

      --------------------
      -- Get_Socket_Set --
      --------------------

      entry Get_Socket_Set (Socket_Set : out Socket_Set_Type)
        when not Builders.Is_Empty is
      begin
         Empty (Socket_Set);

         for B of Builders loop
            Set (Socket_Set, Sock (B));
         end loop;
      end Get_Socket_Set;

      ----------------
      -- Initialize --
      ----------------

      procedure Initialize (Builder : in out Build_Master) is
      begin
         Builder.D.Id := Current_Id;
         Current_Id := Current_Id + 1;
      end Initialize;

      ------------
      -- Insert --
      ------------

      procedure Insert (Builder : Build_Master) is
      begin
         Builders.Insert (Builder);
      end Insert;

      ----------
      -- Lock --
      ----------

      entry Lock (Builder : in out Build_Master) when True is
      begin
         if Builder.D.Locked then
            requeue Try_Lock;
         else
            Builder.D.Locked := True;
         end if;
      end Lock;

      -------------
      -- Release --
      -------------

      procedure Release (Builder : in out Build_Master) is
      begin
         Builder.D.Locked := False;
         if Try_Lock'Count > 0 then
            To_Check := To_Check + Try_Lock'Count;
         end if;
      end Release;

      ------------
      -- Remove --
      ------------

      procedure Remove (Builder : in out Build_Master) is
      begin
         Builders.Exclude (Builder);
         Release (Builder);
      end Remove;

      --------------
      -- Try_Lock --
      --------------

      entry Try_Lock (Builder : in out Build_Master) when To_Check > 0 is
      begin
         To_Check := To_Check - 1;

         if Builder.D.Locked then
            requeue Try_Lock;
         else
            Builder.D.Locked := True;
         end if;
      end Try_Lock;

      ------------------------
      -- Working_Dir_Exists --
      ------------------------

      function Working_Dir_Exists (Directory : String) return Boolean is
      begin
         for B of Builders loop
            if Work_Directory (B) = Directory then
               return True;
            end if;
         end loop;
         return False;
      end Working_Dir_Exists;

   end Builders;

   -------------------
   -- Close_Builder --
   -------------------

   procedure Close_Builder (Builder : in out Build_Master; Ack : Boolean) is
   begin
      --  First unregister the builder

      Builders.Remove (Builder);
      Running.Kill_Processes (Sock (Builder));

      --  Send an Ack message before closing if requested

      if Ack then
         begin
            Send_Ok (Builder.D.Channel);
         exception
            when others =>
               null;
         end;
      end if;

      --  Now shutdown the socket. This routine is used when the builder
      --  has encountered an error, so the associated socket may be in a bad
      --  state. Make sure we do not fail here.

      Close (Builder.D.Channel);
   end Close_Builder;

   -----------------------------
   -- Controlled_Build_Master --
   -----------------------------

   protected body Controlled_Build_Master is

      ------------
      -- Adjust --
      ------------

      procedure Adjust (Builder : in out Build_Master) is
      begin
         Builder.D.Count := Builder.D.Count + 1;
      end Adjust;

      --------------
      -- Finalize --
      --------------

      procedure Finalize (Builder : in out Build_Master) is
         procedure Unchecked_Free is
           new Unchecked_Deallocation (Data, Shared_Data);
         S : Shared_Data := Builder.D;
      begin
         Builder.D := null;

         S.Count := S.Count - 1;

         if S.Count = 0 then
            Unchecked_Free (S);
         end if;
      end Finalize;

      ----------------
      -- Initialize --
      ----------------

      procedure Initialize (Builder : in out Build_Master) is
      begin
         Builder.D := new Data'
           (Channel                    => No_Channel,
            Project_Name               => Null_Unbounded_String,
            Target                     => Null_Unbounded_String,
            Build_Env                  => Null_Unbounded_String,
            Included_Artifact_Patterns => <>,
            Id                         => 0,
            Locked                     => False,
            Count                      => 1);
      end Initialize;

   end Controlled_Build_Master;

   -------------
   -- Display --
   -------------

   procedure Display
     (Str      : String;
      Is_Debug : Boolean := False;
      Force    : Boolean := False) is
   begin
      if Force or (Verbose and not Is_Debug) or (Debug and Is_Debug) then
         IO.Message (Str, Is_Debug);
      end if;
   end Display;

   procedure Display
     (Builder  : Build_Master;
      Str      : String;
      Is_Debug : Boolean := False;
      Force    : Boolean := False) is
   begin
      if Force or (Verbose and not Is_Debug) or (Debug and Is_Debug) then
         IO.Message (Builder, Str, Is_Debug);
      end if;
   end Display;

   --------------
   -- Finalize --
   --------------

   overriding procedure Finalize (Builder : in out Build_Master) is
   begin
      Controlled_Build_Master.Finalize (Builder);
   end Finalize;

   -------------
   -- Get_Arg --
   -------------

   function Get_Arg (Builder : Build_Master; Value : String) return String is
      P : constant Natural := Fixed.Index (Value, WD_Path_Tag);
   begin
      if P = 0 then
         return Value;
      else
         return Value (Value'First .. P - 1)
           & Work_Directory (Builder)
           & Directory_Separator
           & Get_Arg (Builder, Value (P + WD_Path_Tag'Length .. Value'Last));
      end if;
   end Get_Arg;

   --------------
   -- Get_Args --
   --------------

   function Get_Args
     (Builder : Build_Master; Slices : Slice_Set) return Argument_List
   is
      Args : Argument_List (1 .. Integer (Slice_Count (Slices)));
   begin
      for K in Args'Range loop
         Args (K) := new String'
           (Get_Arg (Builder, Slice (Slices, Slice_Number (K))));
      end loop;

      return Args;
   end Get_Args;

   -----------------
   -- Get_Slave_Id --
   -----------------

   function Get_Slave_Id return Remote_Id is
      use GNAT.CRC32;
      CRC : GNAT.CRC32.CRC32;
   begin
      Initialize (CRC);

      --  Add host name
      Update (CRC, Host_Name);

      --  Add root directory
      Update (CRC, Root_Directory.all);

      --  Add port
      Update (CRC, Integer'Image (Port));

      --  Set the host id as the 32 higher bits
      return Remote_Id (Get_Value (CRC)) * 2 ** 32;
   end Get_Slave_Id;

   -----------
   -- Image --
   -----------

   function Image (Value : Long_Integer) return String is
      I : constant String := Long_Integer'Image (Value);
   begin
      return (if I (I'First) = '-'
              then I
              else I (I'First + 1 .. I'Last));
   end Image;

   ----------------
   -- Initialize --
   ----------------

   overriding procedure Initialize (Builder : in out Build_Master) is
   begin
      Controlled_Build_Master.Initialize (Builder);
   end Initialize;

   --------
   -- IO --
   --------

   protected body IO is

   -------------
   -- Message --
   -------------

      procedure Message
        (Str      : String;
         Is_Debug : Boolean := False) is
      begin
         Put_Line
           ('[' & Calendar.Formatting.Image (Calendar.Clock) & "] "
            & (if Is_Debug then "# " else " ") & Str);
      end Message;

      procedure Message
        (Builder  : Build_Master;
         Str      : String;
         Is_Debug : Boolean := False)
      is
         package UID_IO is new Text_IO.Modular_IO (UID);
      begin
         UID_IO.Put (Builder.D.Id, Width => 4);
         Put (' ');
         Message (Str, Is_Debug);
      end Message;

      -----------
      -- Spawn --
      -----------

      procedure Spawn
        (Driver   : String;
         Options  : Argument_List;
         Out_File : String;
         Pid      : out Process_Id) is
      begin
         Pid := OS_Lib.Non_Blocking_Spawn (Driver, Options, Out_File);
      end Spawn;

   end IO;

   ------------------------
   -- Parse_Command_Line --
   ------------------------

   procedure Parse_Command_Line is
      use GNAT.Command_Line;

      procedure Usage;

      procedure Check_Version_And_Help is new
        Check_Version_And_Help_G (Usage);

      Config : Command_Line_Configuration;

      -----------
      -- Usage --
      -----------

      procedure Usage is
      begin
         Display_Help (Config);
      end Usage;

   begin
      Define_Switch
        (Config, Help'Access,
         "-h", Long_Switch => "--help",
         Help => "display this help message and exit");

      Define_Switch
        (Config, Verbose'Access,
         "-V", Long_Switch => "--version",
         Help => "display version and exit");

      Define_Switch
        (Config, Max_Processes'Access,
         "-j:", Long_Switch => "--jobs=",
         Initial => Integer (Multiprocessors.Number_Of_CPUs),
         Default => Integer (Multiprocessors.Number_Of_CPUs),
         Help    => "set the maximum simultaneous compilation");

      Define_Switch
        (Config, Max_Responses'Access,
         "-r:", Long_Switch => "--response-handler=",
         Initial => Integer (2),
         Default => Integer (2),
         Help    => "maximum number of simultaneous responses sent back");

      Define_Switch
        (Config, Root_Directory'Access,
         "-d:", Long_Switch => "--directory=",
         Help => "set the root directory");

      Define_Switch
        (Config, Port'Access,
         "-p:", Long_Switch => "--port=",
         Initial => Integer (Default_Port),
         Default => Integer (Default_Port),
         Help    => "set the port the slave will listen to");

      Define_Switch
        (Config, Verbose'Access,
         "-v", Long_Switch => "--verbose",
         Help => "verbose mode, display extra information");

      Define_Switch
        (Config, Debug'Access,
         "-vv", Long_Switch => "--debug",
         Help => "debug mode, display lot of information (imply -v)");

      Define_Switch
        (Config, Hash'Access,
         "-s:", Long_Switch => "--hash=",
         Help => "specify a hash, must match with master");

      Set_Usage (Config, Usage => "[switches]");

      Check_Version_And_Help ("GPRSLAVE", "2013");

      Getopt (Config);

      if Debug then
         Verbose := True;
      end if;

      --  To avoid error messages for unknown languages that are not described
      --  in the XML database, use the quiet mode if Verbose is not set.

      if not Verbose then
         Opt.Quiet_Output := True;
      end if;

      --  First ensure Root_Directory is an absolute path-name. This is
      --  needed to be able to create directory for a specific builder without
      --  enforcing that the current directory be in a critical section.
      --  Indeed, it is then possible to create a directory under this
      --  absolute path-name directly.

      if not Is_Absolute_Path (Root_Directory.all) then

         --  Not an absolute path, this means that we have passed a directory
         --  relative to the current directory with option -d/--directory.

         declare
            RD : constant String := Root_Directory.all;
         begin
            Free (Root_Directory);
            Root_Directory := new String'(Get_Current_Dir & RD);
         end;
      end if;

      --  Ensure Root_Directory does not ends with a directory separator

      if Root_Directory (Root_Directory'Last) in '/' | '\' then
         Delete_Last : declare
            RD : constant String := Root_Directory
              (Root_Directory'First .. Root_Directory'Last - 1);
         begin
            Free (Root_Directory);
            Root_Directory := new String'(RD);
         end Delete_Last;
      end if;

      Running.Set_Max (Max_Processes);

      Free (Config);

   exception
      when Invalid_Switch =>
         OS_Exit (1);

      when Exit_From_Command_Line =>
         OS_Exit (1);
   end Parse_Command_Line;

   -------------------
   -- Wait_Requests --
   -------------------

   task body Wait_Requests is

      procedure Close_Socket_Set (Set : in out Socket_Set_Type);
      --  Close all sockets in the given Set. The corresponding build masters
      --  are closed too.

      ----------------------
      -- Close_Sokcet_Set --
      ----------------------

      procedure Close_Socket_Set (Set : in out Socket_Set_Type) is
         Builder : Build_Master;
         Socket  : Socket_Type;
      begin
         loop
            Get (Set, Socket);

            exit when Socket = No_Socket;

            Builder := Builders.Get (Socket);
            Close_Builder (Builder, Ack => False);
            Display (Builder, "error socket ", Force => True);
         end loop;
      end Close_Socket_Set;

      type Job_Number is mod 2**32;
      --  A 32bits integer which wrap around. This is no problem as we want
      --  to be able to identify running process. There won't be 2**32 process
      --  running at the same time. So it is safe restart numbering at 0.

      Selector     : Selector_Type;
      R_Socket_Set : Socket_Set_Type;
      E_Socket_Set : Socket_Set_Type;
      Empty_Set    : Socket_Set_Type;
      Status       : Selector_Status;
      Builder      : Build_Master;
      Socket       : Socket_Type;
      Jid          : Job_Number := 0;
   begin
      --  Create selector

      Create_Selector (Selector);
      Empty (Empty_Set);

      --  For now do not check write status

      Handle_Commands : loop

         --  Wait for some commands from one of the build master

         Builders.Get_Socket_Set (R_Socket_Set);

         Copy (R_Socket_Set, E_Socket_Set);

         Wait_Incoming_Data : loop
            begin
               Check_Selector
                 (Selector, R_Socket_Set, Empty_Set, E_Socket_Set, Status);
               exit Wait_Incoming_Data;
            exception
               when E : Socket_Error =>
                  if Resolve_Exception (E) /= Interrupted_System_Call then
                     Status := Aborted;
                     exit Wait_Incoming_Data;
                  end if;
            end;
         end loop Wait_Incoming_Data;

         --  Check for socket errors first, if a socket is in error just
         --  close the corresponding builder and remove it from the list.
         --  From there we abort any further actions for those builders.

         Close_Socket_Set (E_Socket_Set);

         if Status = Aborted then
            --  Either the selector has been aborted or the Socket was not
            --  found in the response. We can suppose that in this case the
            --  client is killed and we do not have to keep it in the registry.

            Close_Socket_Set (R_Socket_Set);

         else
            --  Now, check for socket ready for reading. Just get the first
            --  one, other requests will be handled in next iteration.

            Get (R_Socket_Set, Socket);

            if Socket /= No_Socket then
               Builder := Builders.Get (Socket);

               if Is_Active_Build_Master (Builder) then
                  Builders.Lock (Builder);

                  declare
                     Cmd : constant Command := Get_Command (Builder.D.Channel);
                  begin
                     if Debug then
                        declare
                           List : constant Argument_List_Access := Args (Cmd);
                           V    : Unbounded_String;
                        begin
                           V := To_Unbounded_String
                             ("command: " & Command_Kind'Image (Kind (Cmd)));

                           if List /= null then
                              for K in List'Range loop
                                 Append (V, ", " & List (K).all);
                              end loop;
                           end if;

                           Display (Builder, To_String (V), Is_Debug => True);
                        end;
                     end if;

                     if Kind (Cmd) = EX then
                        Record_Job : declare
                           Id : constant Remote_Id :=
                                  Slave_Id + Remote_Id (Jid);
                           --  Note that the Id above should be unique across
                           --  all running slaves. This is not the process
                           --  id, but an id sent back to the build master
                           --  to identify the actual job.
                        begin
                           Jid := Jid + 1;
                           Display
                             (Builder,
                              "register compilation " & Image (Id), True);

                           Send_Ack (Builder.D.Channel, Id);

                           To_Run.Push
                             (Job_Data'(Cmd,
                              Id, OS_Lib.Invalid_Pid,
                              Null_Unbounded_String,
                              Null_Unbounded_String,
                              Null_Unbounded_String,
                              Null_Unbounded_String,
                              Sock (Builder), J_Created));
                        end Record_Job;

                     elsif Kind (Cmd) = FL then
                        null;

                     elsif Kind (Cmd) = CU then
                        Clean_Up_Request : begin

                           To_Run.Push
                             (Job_Data'(Cmd,
                              0, OS_Lib.Invalid_Pid,
                              Null_Unbounded_String,
                              Null_Unbounded_String,
                              Null_Unbounded_String,
                              Null_Unbounded_String,
                              Sock (Builder), J_Created));
                        end Clean_Up_Request;

                     elsif Kind (Cmd) in EC | SI then
                        --  No more compilation for this project. Send an
                        --  Ack only if we are not handling a kill signal
                        --  (receiving SI means that the socket has been
                        --  detected to be closed).

                        Close_Builder (Builder, Ack => (Kind (Cmd) = EC));

                        Display
                          (Builder,
                           "End project : "
                           & To_String (Builder.D.Project_Name));

                     elsif Kind (Cmd) = SY then
                        --  Synchronization requested
                        declare
                           Empty : Sync.Str_Vect.Vector;
                        begin
                           Compilation.Sync.Send_Files
                             (Builder.D.Channel,
                              Work_Directory (Builder),
                              Empty, Empty,
                              Mode => Sync.To_Master);
                        end;

                     elsif Kind (Cmd) = IR then
                        --  Information requested

                        Send_Info_Response
                          (Builder.D.Channel,
                           GPR.Version.Gpr_Version_String,
                           UTC_Time,
                           "toto"); -- Gprslave.Hash.all);

                     else
                        raise Constraint_Error with "unexpected command "
                          & Command_Kind'Image (Kind (Cmd));
                     end if;

                  exception
                     when Socket_Error =>
                        --  The build master has probably been killed. We
                        --  cannot communicate with it. Just close the channel.

                        Close_Builder (Builder, Ack => False);

                        Display
                          (Builder,
                           "Interrupted project : "
                           & To_String (Builder.D.Project_Name));

                     when E : others =>
                        --  In case of an exception, communication endded
                        --  prematurately or some wrong command received, make
                        --  sure we clean the slave state and we listen to new
                        --  commands. Not doing that could make the slave
                        --  unresponsive.

                        Close_Builder (Builder, Ack => False);

                        Display
                          (Builder,
                           "Error: "
                           & Exception_Information (E), Force => True);
                  end;

                  --  The lock is released and freed if we have an EC command

                  Builders.Release (Builder);

               else
                  Display
                    ("build master not found, cannot handle request.",
                     Is_Debug => True);
               end if;
            end if;
         end if;
      end loop Handle_Commands;

   exception
      when E : others =>
         Display
           (Builder, "Unrecoverable error: Protocol_Handler.", Force => True);
         Display (Builder, Symbolic_Traceback (E), Force => True);
         OS_Exit (1);
   end Wait_Requests;

   -----------------
   -- Execute_Job --
   -----------------

   task body Execute_Job is

      function Get_Driver
        (Builder        : Build_Master;
         Language        : String;
         Target, Runtime : String;
         Project         : String) return String;
      --  Returns the compiler driver for the given language and the current
      --  target as retreived from the initial handshake context exchange.

      function Get_Output_File (Builder : Build_Master) return String;
      --  Returns a unique output file

      procedure Output_Compilation (Builder : Build_Master; File : String);
      --  Output compilation information

      procedure Do_Compile (Job : in out Job_Data);
      --  Run a compilation job

      procedure Do_Clean (Job : Job_Data);
      --  Run  a clean job

      package Drivers_Cache is new Containers.Indefinite_Hashed_Maps
        (String, String,
         Ada.Strings.Hash_Case_Insensitive,
         Ada.Strings.Equal_Case_Insensitive);

      Cache : Drivers_Cache.Map;

      ----------------
      -- Get_Driver --
      ----------------

      function Get_Driver
        (Builder        : Build_Master;
         Language        : String;
         Target, Runtime : String;
         Project         : String) return String
      is
         procedure Look_Driver (Project_Name : String; Is_Config : Boolean);
         --  Set Driver with the found driver for the Language

         Config_Filename    : constant String :=
                                "slave_tmp-" & Language & ".cgpr";
         Key                : constant String :=
                                To_String (Builder.D.Target)
                                & '+' & Language & "+" & Runtime;
         Position           : constant Drivers_Cache.Cursor :=
                                Cache.Find (Key);
         Compilers, Filters : Compiler_Lists.List;
         Requires_Comp      : Boolean;
         Comp               : Compiler_Access;
         Env                : Environment;
         Success            : Boolean;
         Driver             : Unbounded_String := To_Unbounded_String (Key);

         -----------------
         -- Look_Driver --
         -----------------

         procedure Look_Driver (Project_Name : String; Is_Config : Boolean) is
            Project_Node_Tree : GPR.Project_Node_Tree_Ref;
            Project_Node      : Project_Node_Id := Empty_Project_Node;
            Project_Tree      : Project_Tree_Ref;
            Project           : Project_Id;
         begin
            Project_Node_Tree := new Project_Node_Tree_Data;
            GPR.Tree.Initialize (Project_Node_Tree);

            GPR.Part.Parse
              (Project_Node_Tree, Project_Node, Project_Name,
               Errout_Handling   => GPR.Part.Finalize_If_Error,
               Packages_To_Check => null,
               Is_Config_File    => Is_Config,
               Target_Name       => To_String (Builder.D.Target),
               Env               => Env);

            Project_Tree := new Project_Tree_Data;
            GPR.Initialize (Project_Tree);

            Proc.Process
              (Project_Tree, Project, null, Success,
               Project_Node, Project_Node_Tree, Env);

            if not Success then
               return;
            end if;

            declare
               Pcks : Package_Table.Table_Ptr
                        renames Project_Tree.Shared.Packages.Table;
               Pck  : Package_Id := Project.Decl.Packages;
            begin
               Look_Compiler_Package : while Pck /= No_Package loop
                  if Pcks (Pck).Decl /= No_Declarations
                    and then Pcks (Pck).Name = Name_Compiler
                  then
                     --  Look for the Driver ("<language>") attribute

                     declare
                        Id : Array_Id := Pcks (Pck).Decl.Arrays;
                     begin
                        while Id /= No_Array loop
                           declare
                              V : constant Array_Data :=
                                    Project_Tree.Shared.Arrays.Table (Id);
                           begin
                              if V.Name = Name_Driver
                                and then V.Value /= No_Array_Element
                              then
                                 --  Check if element is for the given
                                 --  language, and if so return the
                                 --  corresponding value.

                                 declare
                                    E : constant Array_Element :=
                                          Project_Tree.Shared.
                                            Array_Elements.Table (V.Value);
                                 begin
                                    if Get_Name_String (E.Index) =
                                      To_Lower (Language)
                                    then
                                       Driver := To_Unbounded_String
                                         (Get_Name_String (E.Value.Value));
                                       exit Look_Compiler_Package;
                                    end if;
                                 end;
                              end if;
                           end;

                           Id := Project_Tree.Shared.Arrays.Table (Id).Next;
                        end loop;
                     end;
                  end if;

                  Pck := Pcks (Pck).Next;
               end loop Look_Compiler_Package;
            end;

            Free (Project_Node_Tree);
            Free (Project_Tree);
         end Look_Driver;

      begin
         if Drivers_Cache.Has_Element (Position) then
            return Drivers_Cache.Element (Position);

         else
            --  Generate the configuration project for this language and target

            Parse_Config_Parameter
              (Base              => Base,
               Config            => Language & ",," & Runtime,
               Compiler          => Comp,
               Requires_Compiler => Requires_Comp);

            if Requires_Comp then
               Filters.Append (Comp);
            else
               Compilers.Append (Comp);
            end if;

            Get_Targets_Set (Base, Target, Selected_Targets_Set);

            declare
               Used_Target : Unbounded_String := To_Unbounded_String (Target);
            begin
               Complete_Command_Line_Compilers
                 (Base,
                  Selected_Targets_Set,
                  Filters,
                  Compilers,
                  Target_Specified => True,
                  Selected_Target  => Used_Target);
            end;

            --  Generate configuration project file

            Generate_Configuration
              (Base, Compilers, Config_Filename,
               To_String (Builder.D.Target),
               Selected_Targets_Set);

            GPR.Tree.Initialize (Env, GPR.Gprbuild_Flags);
            GPR.Initialize (GPR.No_Project_Tree);

            GPR.Env.Initialize_Default_Project_Path
              (Env.Project_Path, Target_Name => To_String (Builder.D.Target));

            --  Parse it to find the driver for this language

            Look_Driver (Config_Filename, Is_Config => True);
            Directories.Delete_File (Config_Filename);

            --  Language is not found in the knowledge base, check the project
            --  to see if there is a definition for the language.

            if Driver = Key then
               Look_Driver (Project, Is_Config => False);

               --  Ensure that we have a full-path name

               if Driver = Key then
                  --  Driver not found, use <target>-gcc if it exists
                  Driver := Builder.D.Target & "-gcc";
               end if;

               declare
                  Exe : OS_Lib.String_Access :=
                          Locate_Exec_On_Path (To_String (Driver));
               begin
                  if Exe = null then
                     Display
                       (Builder,
                        "Can't locate " & To_String (Driver) & " in path",
                        Is_Debug => True);

                     return Key;
                  end if;

                  Driver := To_Unbounded_String (Exe.all);
                  Free (Exe);
               end;
            end if;

            --  Record this driver for the language and target into the cache

            Cache.Insert (Key, To_String (Driver));

            --  Clean-up and free project structure

            Display
              (Builder,
               "driver for " & Language & " is : " & To_String (Driver),
               Is_Debug => True);

            return To_String (Driver);
         end if;

      exception
         when E : others =>

            Display
              (Builder,
               Ada.Exceptions.Exception_Information (E) & ASCII.LF
               & "on get driver for " & Language & " by key " & Key,
               Is_Debug => True);

            --  Be sure we never propagate an exception from this routine, in
            --  case of problem we just return the key, this will be used as an
            --  executable and will be reported to the master as a proper build
            --  failure.
            return Key;
      end Get_Driver;

      ---------------------
      -- Get_Output_File --
      ---------------------

      function Get_Output_File (Builder : Build_Master) return String is
         Filename : constant String := "output.slave." & Image (Index);
      begin
         Index := Index + 1;
         return Compose (Work_Directory (Builder), Filename);
      end Get_Output_File;

      ------------------------
      -- Output_Compilation --
      ------------------------

      procedure Output_Compilation
        (Builder : Build_Master;
         File    : String)
      is

         function Prefix return String;
         --  Returns a prefix for the display with a progress indication

         ------------
         -- Prefix --
         ------------

         function Prefix return String is
            Active : constant String := Natural'Image (Running.Count + 1);
            Max    : constant String := Natural'Image (Max_Processes);
         begin
            return "Compiling (" & Active (Active'First + 1 .. Active'Last)
              & '/' & Max (Max'First + 1 .. Max'Last) & ") : ";
         end Prefix;

         RDL : constant Natural := Root_Directory'Length;

      begin
         if Verbose then
            if File'Length > RDL
              and then File (File'First .. File'First + RDL - 1)
              = Root_Directory.all
            then
               Display
                 (Builder,
                  Prefix & File (File'First + RDL + 1 .. File'Last));
            else
               Display (Builder, Prefix & File);
            end if;
         end if;
      end Output_Compilation;

      ----------------
      -- Do_Compile --
      ----------------

      procedure Do_Compile (Job : in out Job_Data) is
         Builder : constant Build_Master := Builders.Get (Job.Build_Sock);
         Dir     : constant String := Args (Job.Cmd)(2).all;
         List    : Slice_Set;
      begin
         --  Enter a critical section to:
         --     - move to directory where the command is executed
         --     - execute the compilation command
         --     - register a new job and acknowledge
         --     - move back to working directory

         Display
           (Builder, "move to work directory " & Work_Directory (Builder),
            Is_Debug => True);

         --  It is safe to change directory here without a lock as this is
         --  the only place where it happens and there is a single instance
         --  of this task.

         Set_Directory (Work_Directory (Builder));

         --  Create/Move to object dir if any, note that if we
         --  have an absolute path name here it is because the
         --  Build_Root is probably not properly set. Try to fail
         --  gracefully to report a proper error message to the
         --  build master.
         --
         --  If we have an absolute pathname, just start the
         --  process into the to directory. The output file will
         --  be created there and will be reported to the master.
         --
         --  Note that the following block should never fail otherwise the
         --  process won't be started. Even if we know the compilation will
         --  fail we need to move forward as the result for this compilation
         --  is waited for by the build master.

         begin
            if Dir /= "" then
               if not Is_Absolute_Path (Dir)
                 and then not Is_Directory (Dir)
               then
                  Create_Directory (Dir);
               end if;

               Display
                 (Builder, "move to directory " & Dir, Is_Debug => True);

               Set_Directory (Dir);
            end if;
         exception
            when others =>
               Display
                 (Builder, "cannot move to object directory",
                  Is_Debug => True);
         end;

         Create (List, Args (Job.Cmd) (8).all, String'(1 => Opts_Sep));

         Execute  : declare
            Project   : constant String :=
                          Get_Arg (Builder, Args (Job.Cmd) (1).all);
            Language  : constant String := Args (Job.Cmd) (3).all;
            Target    : constant String := Args (Job.Cmd) (4).all;
            Runtime   : constant String := Args (Job.Cmd) (5).all;
            Out_File  : constant String :=
                          Get_Output_File (Builder);
            Obj_File  : constant String := Args (Job.Cmd) (6).all;
            Dep_File  : constant String := Args (Job.Cmd) (7).all;
            Env       : constant String :=
                          Get_Arg (Builder, Args (Job.Cmd) (9).all);
            O         : Argument_List := Get_Args (Builder, List);
            First_Opt : Positive := O'First;
            Pid       : Process_Id;
            Driver    : Unbounded_String;
         begin
            Output_Compilation (Builder, O (O'Last).all);

            --  Set compiler environment

            Set_Env (Env, Fail => False, Force => True);

            --  It is critical to ensure that no IO is done while spawning
            --  the process.

            --  If there is now language set, we are not calling a compiler
            --  but a tool directly (gprbuild from GPRremote for example). In
            --  this case the driver is taken from the first option in the
            --  list.
            --
            --  When language is not null we compute the driver to be used
            --  based on the project setting for this specific language.

            if Language = "" then
               declare
                  Drv : OS_Lib.String_Access :=
                          Locate_Exec_On_Path (O (O'First).all);
               begin
                  Driver := To_Unbounded_String (Drv.all);
                  Free (Drv);
               end;

               --  And skip first option which was the driver

               First_Opt := First_Opt + 1;

            else
               Driver := To_Unbounded_String
                           (Get_Driver (Builder, Language,
                                        Target, Runtime, Project));
            end if;

            Running.Start
              (Job      => Job,
               Driver   => To_String (Driver),
               Options  => O (First_Opt .. O'Last),
               Out_File => Out_File,
               Obj_File => Obj_File,
               Dep_File => Dep_File,
               Dep_Dir  => (if Is_Absolute_Path (Dir) then "" else Dir),
               Pid      => Pid);

            Display
              (Builder, "  pid" & Integer'Image (Pid_To_Integer (Pid)),
               Is_Debug => True);
            Display (Builder, "  obj_file " & Obj_File, Is_Debug => True);
            Display (Builder, "  dep_file " & Dep_File, Is_Debug => True);
            Display (Builder, "  out_file " & Out_File, Is_Debug => True);

            for K in O'Range loop
               Free (O (K));
            end loop;
         end Execute;
      exception
         when E : others =>
            Display
              (Builder,
               "Error in Execute_Job: " & Symbolic_Traceback (E),
               Is_Debug => True);
      end Do_Compile;

      --------------
      -- Do_Clean --
      --------------

      procedure Do_Clean (Job : Job_Data) is
         Builder : constant Build_Master := Builders.Get (Job.Build_Sock);
      begin
         Builder.D.Project_Name :=
           To_Unbounded_String (Args (Job.Cmd)(1).all);

         declare
            WD : constant String := Work_Directory (Builder);
         begin
            if Exists (WD) then
               Display (Builder, "Delete " & WD);

               --  Cannot delete if the process is still under
               --  the working directory, so move to the slave
               --  root directory.

               Set_Directory (Root_Directory.all);

               Delete_Tree (WD);
            end if;
         end;

         Send_Ok (Builder.D.Channel);
      exception
         when E : others =>
            Display
              (Builder,
               "clean-up error " & Symbolic_Traceback (E),
               True);
            Send_Ko (Builder.D.Channel);
      end Do_Clean;

      Job : Job_Data;
   begin
      loop
         --  Launch a new compilation only if the maximum of simultaneous
         --  process has not yet been reached.

         Running.Wait_Slot;

         To_Run.Pop (Job);

         --  Only launch the job if the corresponding builder is still active.
         --  It could be the case that the builder has been interrupted
         --  (ctrl-c) and so removed from the set.

         if Builders.Exists (Job.Build_Sock) then
            if Kind (Job.Cmd) = EX then
               --  Note that we do not release the job here as it will
               --  get recorded as running job. The release will happen
               --  in Wait_Completion.
               Do_Compile (Job);

            else
               Do_Clean (Job);
            end if;
         end if;
      end loop;

   exception
      when E : others =>
         Display ("Unrecoverable error: Execute_Job.", Force => True);
         Display (Exception_Information (E), Force => True);
         OS_Exit (1);
   end Execute_Job;

   -------------
   -- Running --
   -------------

   protected body Running is

      procedure Register (Job : Job_Data)
        with Pre => Job.Stage = J_Running;
      --  Register a running Job

      -----------
      -- Count --
      -----------

      function Count return Natural is
      begin
         return N_Count;
      end Count;

      --------------------
      -- Kill_Processes --
      --------------------

      procedure Kill_Processes (Socket : Socket_Type) is
         To_Kill : Job_Data_Set.Set;
         C       : Job_Data_Set.Cursor;
      begin
         --  First pass, record all job for the given builder

         for Job of Set loop
            if Job.Build_Sock = Socket then
               To_Kill.Insert (Job);
            end if;
         end loop;

         --  Second pass, kill processes and mark them as killed. Those jobs
         --  are interrupted and the builder removed, so there is no point to
         --  try to send back the compilation result to the master.
         --
         --  This also ensure a faster termination of the build master.

         for Job of To_Kill loop
            --  Mark job as killed into the set
            C := Set.Find (Job);
            Set (C).Stage := J_Killed;

            Kill_Process_Tree (Job.Pid, Hard_Kill => True);
            Display
              ("kill job" & Integer'Image (Pid_To_Integer (Job.Pid)),
               Is_Debug => True);
         end loop;
      end Kill_Processes;

      --------------
      -- Register --
      --------------

      procedure Register (Job : Job_Data) is
      begin
         --  Let's ensure that while the job was prepared the builder was not
         --  hard-killed. If so we kill the process right now. The result won't
         --  be used anyway and we do not want it to linger here and possibly
         --  corrupt a new launched compilation for the same object file.
         --
         --  Note that it is still inserted into the job set for the job exit
         --  status to be read. This ensure that the job is properly terminated
         --  by the OS (on Linux the process would stay as <defunct> for
         --  example).

         if not Builders.Exists (Job.Build_Sock) then
            Display
              ("kill job (missing builder)"
               & Integer'Image (Pid_To_Integer (Job.Pid)),
               Is_Debug => True);

            Kill (Job.Pid, Hard_Kill => True);

            Insert_Killed_Job : declare
               Killed_Job : Job_Data := Job;
            begin
               Killed_Job.Stage := J_Killed;
               Set.Insert (Killed_Job);
            end Insert_Killed_Job;

         elsif Job.Pid = OS_Lib.Invalid_Pid then
            Dead.Insert (Job);
         else
            Set.Insert (Job);
         end if;

         N_Count := N_Count + 1;
      end Register;

      -----------
      -- Start --
      -----------

      procedure Start
        (Job      : in out Job_Data;
         Driver   : String;
         Options  : Argument_List;
         Out_File : String;
         Obj_File : String;
         Dep_File : String;
         Dep_Dir  : String;
         Pid      : out Process_Id) is
      begin
         if Debug then
            Put (Driver);
            Put (' ');

            for O of Options loop
               Put (O.all);
               Put (' ');
            end loop;
            New_Line;
         end if;

         IO.Spawn (Driver, Options, Out_File, Pid);

         Job.Pid      := Pid;
         Job.Dep_File := To_Unbounded_String (Dep_File);
         Job.Obj_File := To_Unbounded_String (Obj_File);
         Job.Output   := To_Unbounded_String (Out_File);
         Job.Dep_Dir  := To_Unbounded_String (Dep_Dir);
         Job.Stage    := J_Running;

         --  Note that we want to register the job even if Pid is
         --  Invalid_Process. We want it to be recorded into the running
         --  process to be able to be retrieved by the Wait_Completion
         --  task and a proper NOK message to be sent to the builder.

         Register (Job);
      end Start;

      ---------
      -- Get --
      ---------

      procedure Get (Job : out Job_Data; Pid : Process_Id) is
         Pos : Job_Data_Set.Cursor;
      begin
         if Dead.Is_Empty then
            Job := No_Job;
            Job.Pid := Pid;
            Pos := Set.Find (Job);

            --  Not that a job could be not found here because the Pid is one
            --  of gprconfig runned to generate a configuration file for a
            --  specific language.

            if Job_Data_Set.Has_Element (Pos) then
               Job := Job_Data_Set.Element (Pos);
               Set.Delete (Job);
               N_Count := N_Count - 1;

               --  If this is a job which has been killed (see Kill_Processes
               --  above), set to No_Job. We do this as the Wait_Completion
               --  task must not do anything with such a process (no need to
               --  send back answers as anyway the build master is not running
               --  anymore).

               if Job.Stage = J_Killed then
                  Job := No_Job;
               else
                  Job.Stage := J_Terminated;
               end if;

            else
               Job := No_Job;
            end if;

         else
            Job := Dead.First_Element;
            Job.Stage := J_Terminated;
            Dead.Delete_First;
            N_Count := N_Count - 1;
         end if;
      end Get;

      -------------
      -- Set_Max --
      -------------

      procedure Set_Max (Max : Positive) is
      begin
         Running.Max := Max;
      end Set_Max;

      ----------
      -- Wait --
      ----------

      entry Wait when Count > 0 is
      begin
         null;
      end Wait;

      ---------------
      -- Wait_Slot --
      ---------------

      entry Wait_Slot when Count < Max is
      begin
         null;
      end Wait_Slot;

   end Running;

   ------------
   -- To_Run --
   ------------

   protected body To_Run is

      ----------
      -- Push --
      ----------

      procedure Push (Job : Job_Data) is
         J : Job_Data := Job;
      begin
         --  Always adds the clean-up job in front of the queue, this is
         --  friendler as we do not want the user to wait for all current
         --  compilation to terminate.

         J.Stage := J_Waiting;

         if Kind (Job.Cmd) = CU then
            Set.Prepend (J);
         else
            Set.Append (J);
         end if;
      end Push;

      ---------
      -- Pop --
      ---------

      entry Pop (Job : out Job_Data) when not Set.Is_Empty is
      begin
         Job := Set.First_Element;
         Set.Delete_First;
      end Pop;

   end To_Run;

   ---------------------
   -- Wait_Completion --
   ---------------------

   task body Wait_Completion is

      Pid     : Process_Id;
      Success : Boolean;
      Job     : Job_Data;
      Builder : Build_Master;

      package String_Set is
        new Containers.Indefinite_Vectors (Positive, String);

      function Expand_Artifacts
        (Root      : String;
         Base_Name : String;
         Patterns  : String_Split.Slice_Set) return String_Set.Vector;
      --  Returns the set of artifacts for the Base_Name based on the patterns
      --  given by attribute Included_Artifact_Patterns.

      ----------------------
      -- Expand_Artifacts --
      ----------------------

      function Expand_Artifacts
        (Root      : String;
         Base_Name : String;
         Patterns  : String_Split.Slice_Set) return String_Set.Vector
      is
         Count  : constant Slice_Number := Slice_Count (Patterns);
         Result : String_Set.Vector;
      begin
         for K in 1 .. Count loop
            declare
               Item : constant String := String_Split.Slice (Patterns, K);
               Star : constant Natural := Fixed.Index (Item, "*");
               Name : Unbounded_String;
            begin
               if Item'Length > 0 then
                  --  No start to replace, this is a plain file-name

                  if Star = 0 then
                     Name := To_Unbounded_String (Item);

                  else
                     --  We have a star, replace it with the base name

                     Name := To_Unbounded_String
                       (Item (Item'First .. Star - 1)
                        & Base_Name & Item (Star + 1 .. Item'Last));
                  end if;

                  if Exists (Root & To_String (Name)) then
                     Result.Append (Root & To_String (Name));
                  end if;
               end if;
            end;
         end loop;

         return Result;
      end Expand_Artifacts;

   begin
      loop
         --  Wait for a job to complete only if there is job running

         Running.Wait;

         Wait_Process (Pid, Success);

         --  If a "dead" jobs is returned success is forced to False

         if Pid = OS_Lib.Invalid_Pid then
            Success := False;
         end if;

         Running.Get (Job, Pid);

         --  Note that if there is not such element it could be because the
         --  build master has been killed before the end of the compilation.
         --  In this case an EC message is received by the slave and the
         --  Job_Set is clear. See Main_Loop in gprslave's body.

         if Job /= No_Job then
            --  Now get the corresponding build master

            Builder := Builders.Get (Job.Build_Sock);

            if Is_Active_Build_Master (Builder) then
               Builders.Lock (Builder);

               begin
                  Display
                    (Builder,
                     "job " & Image (Job.Id) & " terminated",
                     Is_Debug => True);

                  declare
                     DS       : Character renames Directory_Separator;
                     Dep_Dir  : constant String := To_String (Job.Dep_Dir);
                     Dep_File : constant String := To_String (Job.Dep_File);
                     Obj_File : constant String := To_String (Job.Obj_File);
                     Out_File : constant String := To_String (Job.Output);
                     S        : Boolean;
                  begin
                     if Exists (Out_File) then
                        Send_Output (Builder.D.Channel, Out_File);
                     end if;

                     OS_Lib.Delete_File (Out_File, S);

                     if Success then
                        --  No dependency or object files to send back if the
                        --  compilation was not successful.

                        declare
                           R_Dir    : constant String :=
                                        Work_Directory (Builder)
                                        & (if Dep_Dir /= ""
                                           then DS & Dep_Dir else "")
                                        & DS;
                           D_File : constant String := R_Dir & Dep_File;
                           O_File : constant String := R_Dir & Obj_File;
                        begin
                           if Dep_File /= ""
                             and then Exists (D_File)
                             and then Kind (D_File) = Ordinary_File
                           then
                              Send_File
                                (Builder.D.Channel, D_File, Rewrite => True);
                           end if;

                           if Obj_File /= "" then
                              if Exists (O_File) then
                                 Send_File
                                   (Builder.D.Channel,
                                    O_File, Rewrite => False);
                              end if;

                              --  We also check for any artifacts based on the
                              --  user's patterns if any.

                              for Artifact of
                                Expand_Artifacts
                                  (Root      => R_Dir,
                                   Base_Name =>
                                     Directories.Base_Name (Obj_File),
                                   Patterns  =>
                                     Builder.D.Included_Artifact_Patterns)
                              loop
                                 Send_File
                                   (Builder.D.Channel, Artifact,
                                    Rewrite => False);
                              end loop;
                           end if;
                        end;
                     end if;
                  end;

                  Display
                    (Builder,
                     "compilation status " & Boolean'Image (Success),
                     Is_Debug => True);

                  if Success then
                     Send_Ok (Builder.D.Channel, Job.Id);
                  else
                     Send_Ko (Builder.D.Channel, Job.Id);
                  end if;

                  Builders.Release (Builder);

               exception
                  when E : others =>
                     --  An exception can be raised if the builder master has
                     --  been terminated. In this case the communication won't
                     --  succeed.

                     --  Remove it from the list

                     Close_Builder (Builder, Ack => False);

                     Display
                       (Builder,
                        "cannot send response to build master "
                        & Exception_Information (E),
                        Force => True);
               end;

            else
               Display
                 ("build master not found, cannot send response.",
                  Is_Debug => True);
            end if;

         else
            --  This is not necessarily an error as we could get a Pid of a
            --  gprconfig run launched to generate a configuration file for a
            --  specific language. So we do not want to fail in this case.

            Display
              ("unknown job data for pid "
               & Integer'Image (Pid_To_Integer (Pid)), Is_Debug => True);
         end if;
      end loop;

   exception
      when E : others =>
         Put_Line
           ("Unrecoverable error: Wait_Completion: " & Exception_Name (E));
         Put_Line (Symbolic_Traceback (E));
         OS_Exit (1);
   end Wait_Completion;

   ---------------------
   -- Wait_For_Master --
   ---------------------

   procedure Wait_For_Master is
      use Stamps;

      procedure Sync_Gpr (Builder : in out Build_Master);

      --------------
      -- Sync_Gpr --
      --------------

      procedure Sync_Gpr (Builder : in out Build_Master) is

         procedure Delete_Files (Except : Sync.Files.Set);
         --  Delete all files in the current working tree except those in
         --  Except set.

         procedure Display (Message : String);
         --  Display message callback

         WD : constant String := Work_Directory (Builder);

         ------------------
         -- Delete_Files --
         ------------------

         procedure Delete_Files (Except : Sync.Files.Set) is

            procedure Process (Path : String);
            --  Search recursively the Path

            procedure Process (Path : String) is

               procedure Check (File : Directory_Entry_Type);
               --  Remove this file if not part of Except set

               -----------
               -- Check --
               -----------

               procedure Check (File : Directory_Entry_Type) is
                  S_Name     : constant String := Simple_Name (File);
                  Entry_Name : constant String :=
                                 Path & Directory_Separator & S_Name;
               begin
                  if Kind (File) = Directory then
                     if S_Name not in "." | ".."
                       and then not Is_Symbolic_Link (Entry_Name)
                     then
                        Process (Entry_Name);
                     end if;

                  else
                     if not Except.Contains (Entry_Name) then
                        Display
                          (Builder,
                           "delete excluded '" & Entry_Name & ''',
                           Is_Debug => True);

                        Delete_File (Entry_Name);
                     end if;
                  end if;
               end Check;

            begin
               Search
                 (Directory => Path,
                  Pattern   => "*",
                  Filter    => (Special_File => False, others => True),
                  Process   => Check'Access);
            end Process;

         begin
            Process (WD);
         end Delete_Files;

         -------------
         -- Display --
         -------------

         procedure Display (Message : String) is
         begin
            if Debug then
               Display (Message, Is_Debug => True);
            else
               Display (Builder, Message);
            end if;
         end Display;

         Total_File        : Natural;
         Total_Transferred : Natural;
         In_Master         : Sync.Files.Set;

         Result            : constant Protocol.Command_Kind :=
                               Sync.Receive_Files (Builder.D.Channel,
                                                   WD,
                                                   Total_File,
                                                   Total_Transferred,
                                                   In_Master,
                                                   Debug,
                                                   Display'Access);

      begin
         if Result = ES then
            --  Delete all files not part of the list sent by the master.
            --  This is needed to remove files in previous build removed
            --  since then on the master. Again we need to do that as we
            --  can't let around unnedded specs or bodies.

            Delete_Files (Except => In_Master);

         elsif Result in EC | SI then
            --  Cannot communicate with build master anymore, we then
            --  receive an end-of-compilation. Exit now. Note that we do
            --  not need to remove the builder from the list as it is not
            --  yet registered.

            Close_Builder (Builder, Ack => Result = EC);
         end if;

         Display (Builder, "Files    total:" & Natural'Image (Total_File));
         Display
           (Builder, "  transferred :" & Natural'Image (Total_Transferred));

      exception
         when E : others =>
            Close_Builder (Builder, Ack => False);

            Display (Builder, "Lost connection with " & Image (Address));
            Display (Builder, Exception_Information (E), Is_Debug => True);
      end Sync_Gpr;

      Builder      : Build_Master;
      Clock_Status : Boolean;
      Socket       : Socket_Type;

   begin
      --  Wait for a connection

      Wait_Incoming_Master : loop
         begin
            Accept_Socket (Server, Socket, Address);
            exit Wait_Incoming_Master;
         exception
            when E : Socket_Error =>
               if Resolve_Exception (E) /= Interrupted_System_Call then
                  raise;
               end if;
         end;
      end loop Wait_Incoming_Master;

      Builder.D.Channel := Create (Socket);

      --  Then initialize the new builder Id

      Builders.Initialize (Builder);

      Display (Builder, "Connecting with " & Image (Address));

      --  Initial handshake

      declare
         Master_Timestamp : Time_Stamp_Type;
         Version          : Unbounded_String;
         Hash             : Unbounded_String;
         Patterns         : Unbounded_String;
         Is_Ping          : Boolean;
      begin
         Get_Context
           (Builder.D.Channel, Builder.D.Target,
            Builder.D.Project_Name, Builder.D.Build_Env, Builder.Sync,
            Master_Timestamp, Version, Hash, Patterns, Is_Ping);

         --  Set included artifact patterns

         Display
           (Builder,
            "artifact patterns:  " & To_String (Patterns),
            Is_Debug => True);

         String_Split.Create
           (Builder.D.Included_Artifact_Patterns,
            To_String (Patterns), Separators => ";");

         if Is_Ping then
            Send_Ping_Response
              (Builder.D.Channel,
               GPR.Version.Gpr_Version_String,
               UTC_Time,
               Gprslave.Hash.all);

            Close_Builder (Builder, Ack => False);
            Display (Builder, "Ping response to " & Image (Address));
            return;
         end if;

         Clock_Status := Check_Diff (Master_Timestamp, UTC_Time);

         if To_String (Version) /= GPR.Version.Gpr_Version_String (False) then
            Display
              (Builder, "Reject non compatible build for "
               & To_String (Builder.D.Project_Name));

            Display
              (Builder, "builder version " & To_String (Version),
               Is_Debug =>  True);
            Display
              (Builder,
               "slave version   " & GPR.Version.Gpr_Version_String (False),
               Is_Debug =>  True);

            Send_Ko (Builder.D.Channel);
            return;
         end if;

         if Builders.Working_Dir_Exists (Work_Directory (Builder)) then
            Display
              (Builder, "Cannot use the same build environment for "
               & To_String (Builder.D.Project_Name));
            Send_Ko
              (Builder.D.Channel,
               "build environment "
               & To_String (Builder.D.Build_Env) & " already in use");
            return;
         end if;

         --  If a hash has been specified, it must match the one from the
         --  master.

         if Gprslave.Hash /= null
           and then Gprslave.Hash.all /= To_String (Hash)
         then
            Display
              (Builder, "hash does not match "
               & To_String (Builder.D.Project_Name));
            Send_Ko
              (Builder.D.Channel,
               "hash does not match, slave is " & Gprslave.Hash.all);
            return;
         end if;

      exception
         when E : others =>
            --  Do not try to go further, just close the socket
            Close_Builder (Builder, Ack => False);
            Display (Builder, Exception_Information (E));
            return;
      end;

      Display
        (Builder, "Handling project : " & To_String (Builder.D.Project_Name));
      Display (Builder, "Compiling for    : " & To_String (Builder.D.Target));

      if Builder.Sync then
         Display (Builder, "Synchronization from master enabled");
      else
         Display (Builder, "Synchronization from master disabled");
      end if;

      --  Create slave environment if needed

      if not Exists (Work_Directory (Builder)) then
         begin
            Create_Path (Work_Directory (Builder));
         exception
            when others =>
               Send_Ko
                 (Builder.D.Channel,
                  "fail to create build environment directory: "
                  & Work_Directory (Builder));
               Close_Builder (Builder, Ack => False);
               Display
                 (Builder,
                  "failed to create build environment directory: "
                  & Work_Directory (Builder), Force => True);
               return;
         end;

         Display
           (Builder,
            "create build environment directory: "
            & Work_Directory (Builder), Is_Debug => True);
      end if;

      --  Configure slave, note that this does not need to be into the critical
      --  section has the builder is not yet known in the system. At this point
      --  no compilation can be received for this slave anyway.

      Set_Rewrite_WD (Builder.D.Channel, Path => Work_Directory (Builder));

      --  For Ada compilers, rewrite the root directory

      if Compiler_Path = null then
         Display (Builder, "compiler path is null.", Is_Debug => True);
      else
         declare
            C_Path : constant String :=
                       Containing_Directory
                         (Containing_Directory (Compiler_Path.all));
         begin
            Display
              (Builder,
               "compiler path is : " & C_Path,
               Is_Debug => True);

            Set_Rewrite_CD (Builder.D.Channel, Path => C_Path);
         end;
      end if;

      --  It is safe to write to this builder outside of a lock here as this
      --  builder is not yet registered into the slave.

      begin
         Send_Slave_Config
           (Builder.D.Channel, Max_Processes,
            Compose (Root_Directory.all, To_String (Builder.D.Build_Env)),
            Clock_Status);
      exception
         when others =>
            --  build master has aborted, do not try to go further,
            --  just close the socket.
            Close_Builder (Builder, Ack => False);
      end;

      --  If we are using the Gpr synchronisation, it is time to do it here.
      --  Note that we want to avoid the rewriting rules below that are
      --  requiring some CPU cycles not needed at this stage.

      if Sock (Builder) /= No_Socket then
         if Builder.Sync then
            Sync_Gpr (Builder);
         end if;

         --  Register the new builder

         Builders.Insert (Builder);
      end if;

   exception
      when E : others =>
         Display
           (Builder, "Unrecoverable error: Wait_For_Master.", Force => True);
         Display (Builder, Symbolic_Traceback (E), Force => True);
         OS_Exit (1);
   end Wait_For_Master;

   --------------------
   -- Work_Directory --
   --------------------

   function Work_Directory (Builder : Build_Master) return String is
   begin
      return Compose
        (Compose (Root_Directory.all, To_String (Builder.D.Build_Env)),
         To_String (Builder.D.Project_Name));
   end Work_Directory;

begin
   Parse_Command_Line;

   --  Initialize the project support

   Snames.Initialize;

   Parse_Knowledge_Base (Base, Default_Knowledge_Base_Directory);

   Activate_Symbolic_Traceback;

   --  Always create the lib/object directories on the slave, this is needed
   --  when parsing a projet file to retrieve a specific driver.

   Opt.Create_Dirs := Create_All_Dirs;

   --  Setup the response handlers

   if Max_Responses < 1 then
      Max_Responses := 1;
   elsif Max_Responses > Max_Processes then
      Max_Responses := Max_Processes;
   end if;

   Response_Handlers := new Response_Handler_Set (1 .. Max_Responses);

   --  Wait for a gprbuild connection on any addresses

   Address.Addr := Any_Inet_Addr;
   Address.Port := Port_Type (Port);

   Create_Socket (Server);

   Set_Socket_Option (Server, Socket_Level, (Reuse_Address, True));

   Bind_Socket (Server, Address);

   if Port = 0 then
      Address := Get_Socket_Name (Server);
   end if;

   Put_Line
     ("GPRSLAVE " & Version.Gpr_Version_String & " on " & Host_Name
      & ":" & Image (Long_Integer (Address.Port)));
   Put_Line ("  max processes :" & Integer'Image (Max_Processes));
   Put_Line ("  max responses :" & Integer'Image (Max_Responses));

   --  Initialize the host key used to create unique pid

   Slave_Id := Get_Slave_Id;

   Display ("slave id " & Image (Slave_Id), Is_Debug => True);

   Listen_Socket (Server);

   Main_Loop : loop
      Wait_For_Master;
   end loop Main_Loop;

exception
   when E : others =>
      Display ("Unrecoverable error: GprSlave.", Force => True);
      Display (Symbolic_Traceback (E), Force => True);
      OS_Exit (1);
end Gprslave;