------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2012-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library 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. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Containers.Doubly_Linked_Lists; with Ada.Containers.Indefinite_Ordered_Maps; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with GPR.Compilation.Slave; with GPR.Names; use GPR.Names; with GPR.Opt; use GPR.Opt; with GPR.Script; use GPR.Script; package body GPR.Compilation.Process is use Ada; use type Containers.Count_Type; package Env_Maps is new Containers.Indefinite_Ordered_Maps (String, String); -- A set of key=value package Prj_Maps is new Containers.Indefinite_Ordered_Maps (String, Env_Maps.Map, Env_Maps."<", Env_Maps."="); -- A set of project+language=map function "<" (Left, Right : Id) return Boolean is (Left.R_Pid < Right.R_Pid); package Failures_Slave_Set is new Containers.Indefinite_Ordered_Maps (Id, String); function Get_Env (Project : Project_Id; Language : String) return String; -- Get the environment for a specific project and language Environments : Prj_Maps.Map; type Process_Data is record Process : Id; Status : Boolean; end record; package Endded_Process is new Containers.Doubly_Linked_Lists (Process_Data); protected Results is procedure Add (Result : Process_Data); entry Get (Result : out Process_Data); procedure Record_Remote_Failure (Pid : Id; Slave : String); -- This is to be able to display on which slaves a specific compilation -- has failed. function Get_Slave_For (Pid : Id) return String; -- Returns the remote slave for the given compilation, or the empty -- string if the compilation was successful. private List : Endded_Process.List; Failed_Proc : Failures_Slave_Set.Map; end Results; ---------------- -- Add_Result -- ---------------- procedure Add_Result (Process : Id; Status : Boolean; Slave : String := "") is begin Results.Add (Process_Data'(Process, Status)); -- For a compilation failure records the slave to be able to report it if not Status and then Slave /= "" then Results.Record_Remote_Failure (Process, Slave); end if; end Add_Result; ------------------ -- Create_Local -- ------------------ function Create_Local (Pid : Process_Id) return Id is begin return Id'(Local, Pid); end Create_Local; ------------------- -- Create_Remote -- ------------------- function Create_Remote (Pid : Remote_Id) return Id is begin return Id'(Remote, Pid); end Create_Remote; --------------------------- -- Get_Maximum_Processes -- --------------------------- function Get_Maximum_Processes return Positive is begin return Opt.Maximum_Compilers + Slave.Get_Max_Processes; end Get_Maximum_Processes; ------------- -- Get_Env -- ------------- function Get_Env (Project : Project_Id; Language : String) return String is Key : constant String := Get_Name_String (Project.Name) & "+" & Language; Res : Unbounded_String; begin if Environments.Contains (Key) then for C in Environments (Key).Iterate loop if Res /= Null_Unbounded_String then Res := Res & Opts_Sep; end if; Res := Res & Env_Maps.Key (C) & '=' & Env_Maps.Element (C); end loop; end if; return To_String (Res); end Get_Env; ------------------- -- Get_Slave_For -- ------------------- function Get_Slave_For (Pid : Id) return String is begin if Pid.Kind = Local then return ""; else return Results.Get_Slave_For (Pid); end if; end Get_Slave_For; ---------- -- Hash -- ---------- function Hash (Process : Id) return Header_Num is Modulo : constant Integer := Integer (Header_Num'Last) + 1; begin if Process.Kind = Local then return Header_Num (Pid_To_Integer (Process.Pid) mod Modulo); else return Header_Num (Process.R_Pid mod Remote_Id (Modulo)); end if; end Hash; ------------------------ -- Record_Environment -- ------------------------ procedure Record_Environment (Project : Project_Id; Language : Name_Id; Name, Value : String) is Lang : constant String := Get_Name_String (Language); Key : constant String := Get_Name_String (Project.Name) & "+" & Lang; New_Item : Env_Maps.Map; begin -- Create new item, variable association New_Item.Include (Name, Value); if Environments.Contains (Key) then if Environments (Key).Contains (Name) then Environments (Key).Replace (Name, Value); else Environments (Key).Insert (Name, Value); end if; else Environments.Insert (Key, New_Item); end if; end Record_Environment; ------------- -- Results -- ------------- protected body Results is --------- -- Add -- --------- procedure Add (Result : Process_Data) is begin List.Append (Result); end Add; --------- -- Get -- --------- entry Get (Result : out Process_Data) when List.Length /= 0 is begin Result := List.First_Element; List.Delete_First; end Get; ------------------- -- Get_Slave_For -- ------------------- function Get_Slave_For (Pid : Id) return String is use type Failures_Slave_Set.Cursor; Pos : constant Failures_Slave_Set.Cursor := Failed_Proc.Find (Pid); begin if Pos = Failures_Slave_Set.No_Element then return ""; else return Failures_Slave_Set.Element (Pos); end if; end Get_Slave_For; --------------------------- -- Record_Remote_Failure -- --------------------------- procedure Record_Remote_Failure (Pid : Id; Slave : String) is begin Failed_Proc.Insert (Pid, Slave); end Record_Remote_Failure; end Results; --------- -- Run -- --------- function Run (Executable : String; Options : String_Vectors.Vector; Project : Project_Id; Obj_Name : String; Source : String := ""; Language : String := ""; Dep_Name : String := ""; Output_File : String := ""; Err_To_Out : Boolean := False; Force_Local : Boolean := False; Response_File : Path_Name_Type := No_Path) return Id is Env : constant String := Get_Env (Project, Language); Success : Boolean; begin -- Run locally first, then send jobs to remote slaves. Note that to -- build remotely we need an output file and a language, if one of -- this requirement is not fulfilled we just run the process locally. if Force_Local or else not Distributed_Mode or else Local_Process.Count < Opt.Maximum_Compilers or else Output_File /= "" or else Language = "" then Run_Local : declare P : Id (Local); Args : String_List_Access := new String_List'(To_Argument_List (Options)); begin Set_Env (Env, Fail => True); if Response_File /= No_Path then declare Opts : constant GNAT.OS_Lib.Argument_List := (1 => new String'("@" & Get_Name_String (Response_File))); begin P.Pid := Non_Blocking_Spawn (Executable, Opts); end; elsif Output_File /= "" then P.Pid := Non_Blocking_Spawn (Executable, Args.all, Output_File, Err_To_Out); elsif Source /= "" and then not No_Complete_Output then P.Pid := Non_Blocking_Spawn (Executable, Args.all, Stdout_File => Source & ".stdout", Stderr_File => Source & ".stderr"); else if Source /= "" then Delete_File (Source & ".stdout", Success); Delete_File (Source & ".stderr", Success); end if; P.Pid := Non_Blocking_Spawn (Executable, Args.all); end if; Check_Local_Process (P); Script_Write (Executable, Options); Free (Args); Local_Process.Increment; return P; end Run_Local; else -- Even if the compilation is done remotely make sure that any -- .stderr/.stdout from a previous local compilation are removed. if Source /= "" then Delete_File (Source & ".stdout", Success); Delete_File (Source & ".stderr", Success); end if; return Slave.Run (Project, Language, Options, Obj_Name, Dep_Name, Env); end if; end Run; ----------------- -- Wait_Result -- ----------------- procedure Wait_Result (Process : out Id; Status : out Boolean) is Data : Process_Data; begin Results.Get (Data); Process := Data.Process; Status := Data.Status; end Wait_Result; end GPR.Compilation.Process;