------------------------------------------------------------------------------
-- --
-- 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 . --
-- --
------------------------------------------------------------------------------
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 ("") 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 -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 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;