[Ada] Restrict simultaneous compilations to one per object dir
Arnaud Charlet
charlet@adacore.com
Thu Sep 9 10:47:00 GMT 2010
A new switch is added to gnatmake: --single-compile-per-obj-dir. When
this switch is used and project files are used, gnatmake will not
spawn more that one compilation for the same object directory, even if
switch -jnn would allow for a larger number of simultaneous compilations.
The test for this is to invoke gnatmake on a project file with many
sources that does not import other project files and with switches -j8
and --single-compile-per-obj-dir: there should not be several
simultaneous compilation processes.
Tested on x86_64-pc-linux-gnu, committed on trunk
2010-09-09 Vincent Celier <celier@adacore.com>
* make.adb (Queue): New package implementing a new impementation of the
queue, taking into account the new switch --single-compile-per-obj-dir.
* makeutl.ads (Single_Compile_Per_Obj_Dir_Switch): New constant String
for gnatmake and gprbuild new switch --single-compile-per-obj-dir.
* opt.ads (One_Compilation_Per_Obj_Dir): New Boolean flag, defauted to
False.
* switch-m.adb (Scan_Make_Switches): Take into account new gnatmake
switch --single-compile-per-obj-dir.
* vms_data.ads: Add qualifier SINGLE_COMPILE_PER_OBJ_DIR for gnatmake
switch --single-compile-per-obj-dir.
* gnat_ugn.texi: Add documentation for new gnatmake switch
--single-compile-per-obj-dir.
-------------- next part --------------
Index: gnat_ugn.texi
===================================================================
--- gnat_ugn.texi (revision 164058)
+++ gnat_ugn.texi (working copy)
@@ -9250,7 +9250,11 @@ itself must not include any embedded spa
@item ^--subdirs^/SUBDIRS^=subdir
Actual object directory of each project file is the subdirectory subdir of the
-object directory specified or defauted in the project file.
+object directory specified or defaulted in the project file.
+
+@item ^--single-compile-per-obj-dir^/SINGLE_COMPILE_PER_OBJ_DIR^
+Disallow simultaneous compilations in the same object directory when
+project files are used.
@item ^--unchecked-shared-lib-imports^/UNCHECKED_SHARED_LIB_IMPORTS^
By default, shared library projects are not allowed to import static library
Index: make.adb
===================================================================
--- make.adb (revision 164058)
+++ make.adb (working copy)
@@ -71,6 +71,7 @@ with Ada.Command_Line; use Ada.
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
+with GNAT.HTable;
with GNAT.Case_Util; use GNAT.Case_Util;
with GNAT.OS_Lib; use GNAT.OS_Lib;
@@ -135,49 +136,6 @@ package body Make is
-- complex, for example in main.1.ada, the termination in this name is
-- ".1.ada" and in main_.ada the termination is "_.ada".
- -------------------------------------
- -- Queue (Q) Manipulation Routines --
- -------------------------------------
-
- -- The Q is used in Compile_Sources below. Its implementation uses the GNAT
- -- generic package Table (basically an extensible array). Q_Front points to
- -- the first valid element in the Q, whereas Q.First is the first element
- -- ever enqueued, while Q.Last - 1 is the last element in the Q.
- --
- -- +---+--------------+---+---+---+-----------+---+--------
- -- Q | | ........ | | | | ....... | |
- -- +---+--------------+---+---+---+-----------+---+--------
- -- ^ ^ ^
- -- Q.First Q_Front Q.Last-1
- --
- -- The elements comprised between Q.First and Q_Front-1 are the elements
- -- that have been enqueued and then dequeued, while the elements between
- -- Q_Front and Q.Last-1 are the elements currently in the Q. When the Q
- -- is initialized Q_Front = Q.First = Q.Last. After Compile_Sources has
- -- terminated its execution, Q_Front = Q.Last and the elements contained
- -- between Q.First and Q.Last-1 are those that were explored and thus
- -- marked by Compile_Sources. Whenever the Q is reinitialized, the elements
- -- between Q.First and Q.Last-1 are unmarked.
-
- procedure Init_Q;
- -- Must be called to (re)initialize the Q
-
- procedure Insert_Q
- (Source_File : File_Name_Type;
- Source_Unit : Unit_Name_Type := No_Unit_Name;
- Index : Int := 0);
- -- Inserts Source_File at the end of Q. Provide Source_Unit when possible
- -- for external use (gnatdist). Provide index for multi-unit sources.
-
- function Empty_Q return Boolean;
- -- Returns True if Q is empty
-
- procedure Extract_From_Q
- (Source_File : out File_Name_Type;
- Source_Unit : out Unit_Name_Type;
- Source_Index : out Int);
- -- Extracts the first element from the Q
-
procedure Insert_Project_Sources
(The_Project : Project_Id;
All_Projects : Boolean;
@@ -190,12 +148,6 @@ package body Make is
-- including, if The_Project is an extending project, sources inherited
-- from projects being extended.
- First_Q_Initialization : Boolean := True;
- -- Will be set to false after Init_Q has been called once
-
- Q_Front : Natural;
- -- Points to the first valid element in the Q
-
Unique_Compile : Boolean := False;
-- Set to True if -u or -U or a project file with no main is used
@@ -216,24 +168,55 @@ package body Make is
N_M_Switch : Natural := 0;
-- Used to count -mxxx switches that can affect multilib
- type Q_Record is record
- File : File_Name_Type;
- Unit : Unit_Name_Type;
- Index : Int;
- end record;
- -- File is the name of the file to compile. Unit is for gnatdist
- -- use in order to easily get the unit name of a file to compile
- -- when its name is krunched or declared in gnat.adc. Index, when not 0,
- -- is the index of the unit in a multi-unit source.
+ package Queue is
+ ---------------------------------
+ -- Queue Manipulation Routines --
+ ---------------------------------
- package Q is new Table.Table (
- Table_Component_Type => Q_Record,
- Table_Index_Type => Natural,
- Table_Low_Bound => 0,
- Table_Initial => 4000,
- Table_Increment => 100,
- Table_Name => "Make.Q");
- -- This is the actual Q
+ procedure Initialize (Queue_Per_Obj_Dir : Boolean);
+ -- Initialize the queue
+
+ function Is_Empty return Boolean;
+ -- Returns True if the queue is empty
+
+ function Is_Virtually_Empty return Boolean;
+ -- Returns True if the queue is empty or if all object directories are
+ -- busy.
+
+ procedure Insert
+ (Source_File_Name : File_Name_Type;
+ Project : Project_Id;
+ Source_Unit : Unit_Name_Type := No_Unit_Name;
+ Index : Int := 0);
+ -- Insert source in the queue
+
+ procedure Extract
+ (Source_File_Name : out File_Name_Type;
+ Source_Unit : out Unit_Name_Type;
+ Source_Index : out Int);
+ -- Get the first source that can be compiled from the queue. If no
+ -- source may be compiled, return No_File/No_Source.
+
+ function Size return Natural;
+ -- Return the total size of the queue, including the sources already
+ -- extracted.
+
+ function Processed return Natural;
+ -- Return the number of source in the queue that have aready been
+ -- processed.
+
+ procedure Set_Obj_Dir_Busy (Obj_Dir : Path_Name_Type);
+ -- Indicate that this object directory is busy, so that when
+ -- One_Compilation_Per_Obj_Dir is True no other compilation occurs in
+ -- this object directory.
+
+ procedure Set_Obj_Dir_Free (Obj_Dir : Path_Name_Type);
+ -- Indicate that there is no compilation for this object directory
+
+ function Element (Rank : Positive) return File_Name_Type;
+ -- Get the file name for element of index Rank in the queue
+
+ end Queue;
-- The 3 following packages are used to store gcc, gnatbind and gnatlink
-- switches found in the project files.
@@ -2503,8 +2486,13 @@ package body Make is
-- library file name. Process_Id of the process spawned to execute the
-- compilation.
+ type ALI_Project is record
+ ALI : ALI_Id;
+ Project : Project_Id;
+ end record;
+
package Good_ALI is new Table.Table (
- Table_Component_Type => ALI_Id,
+ Table_Component_Type => ALI_Project,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 50,
@@ -2519,7 +2507,7 @@ package body Make is
-- Get a mapping file name. If there is one to be reused, reuse it.
-- Otherwise, create a new mapping file.
- function Get_Next_Good_ALI return ALI_Id;
+ function Get_Next_Good_ALI return ALI_Project;
-- Returns the next good ALI_Id record
procedure Record_Failure
@@ -2530,7 +2518,7 @@ package body Make is
-- If Found is False then the compilation of File failed because we
-- could not find it. Records also Unit when possible.
- procedure Record_Good_ALI (A : ALI_Id);
+ procedure Record_Good_ALI (A : ALI_Id; Project : Project_Id);
-- Records in the previous set the Id of an ALI file
function Must_Exit_Because_Of_Error return Boolean;
@@ -2586,6 +2574,10 @@ package body Make is
Project => Arguments_Project);
Outstanding_Compiles := OC1;
+
+ if Arguments_Project /= No_Project then
+ Queue.Set_Obj_Dir_Busy (Arguments_Project.Object_Directory.Name);
+ end if;
end Add_Process;
--------------------
@@ -2624,6 +2616,10 @@ package body Make is
Data := Running_Compile (J);
Project := Running_Compile (J).Project;
+ if Project /= No_Project then
+ Queue.Set_Obj_Dir_Free (Project.Object_Directory.Name);
+ end if;
+
-- If a mapping file was used by this compilation, get its
-- file name for reuse by a subsequent compilation.
@@ -2704,7 +2700,7 @@ package body Make is
end if;
else
- Insert_Q (Sfile, Index => 0);
+ Queue.Insert (Sfile, Project => No_Project, Index => 0);
Mark (Sfile, Index => 0);
end if;
end if;
@@ -3013,6 +3009,7 @@ package body Make is
-------------------------------
procedure Fill_Queue_From_ALI_Files is
+ ALI_P : ALI_Project;
ALI : ALI_Id;
Source_Index : Int;
Sfile : File_Name_Type;
@@ -3022,8 +3019,9 @@ package body Make is
begin
while Good_ALI_Present loop
- ALI := Get_Next_Good_ALI;
- Source_Index := Unit_Index_Of (ALIs.Table (ALI).Afile);
+ ALI_P := Get_Next_Good_ALI;
+ ALI := ALI_P.ALI;
+ Source_Index := Unit_Index_Of (ALIs.Table (ALI_P.ALI).Afile);
-- If we are processing the library file corresponding to the
-- main source file check if this source can be a main unit.
@@ -3109,8 +3107,11 @@ package body Make is
Debug_Msg ("Skipping internal file:", Sfile);
else
- Insert_Q
- (Sfile, Withs.Table (K).Uname, Source_Index);
+ Queue.Insert
+ (Sfile,
+ ALI_P.Project,
+ Withs.Table (K).Uname,
+ Source_Index);
Mark (Sfile, Source_Index);
end if;
end if;
@@ -3156,14 +3157,14 @@ package body Make is
-- Get_Next_Good_ALI --
-----------------------
- function Get_Next_Good_ALI return ALI_Id is
- ALI : ALI_Id;
+ function Get_Next_Good_ALI return ALI_Project is
+ ALIP : ALI_Project;
begin
pragma Assert (Good_ALI_Present);
- ALI := Good_ALI.Table (Good_ALI.Last);
+ ALIP := Good_ALI.Table (Good_ALI.Last);
Good_ALI.Decrement_Last;
- return ALI;
+ return ALIP;
end Get_Next_Good_ALI;
----------------------
@@ -3217,10 +3218,10 @@ package body Make is
-- Record_Good_ALI --
---------------------
- procedure Record_Good_ALI (A : ALI_Id) is
+ procedure Record_Good_ALI (A : ALI_Id; Project : Project_Id) is
begin
Good_ALI.Increment_Last;
- Good_ALI.Table (Good_ALI.Last) := A;
+ Good_ALI.Table (Good_ALI.Last) := (A, Project);
end Record_Good_ALI;
-------------------------------
@@ -3256,8 +3257,10 @@ package body Make is
-- The object file
begin
- if not Empty_Q and then Outstanding_Compiles < Max_Process then
- Extract_From_Q (Source_File, Source_Unit, Source_Index);
+ if not Queue.Is_Virtually_Empty and then
+ Outstanding_Compiles < Max_Process
+ then
+ Queue.Extract (Source_File, Source_Unit, Source_Index);
Osint.Full_Source_Name
(Source_File,
@@ -3387,7 +3390,7 @@ package body Make is
-- The ALI file is up-to-date; record its Id
- Record_Good_ALI (ALI);
+ Record_Good_ALI (ALI, Arguments_Project);
-- Record the time stamp of the most recent object
-- file as long as no (re)compilations are needed.
@@ -3542,7 +3545,7 @@ package body Make is
begin
if Outstanding_Compiles = Max_Process
- or else (Empty_Q
+ or else (Queue.Is_Virtually_Empty
and then not Good_ALI_Present
and then Outstanding_Compiles > 0)
then
@@ -3603,7 +3606,7 @@ package body Make is
end if;
else
- Record_Good_ALI (ALI);
+ Record_Good_ALI (ALI, Data.Project);
end if;
Free (Text);
@@ -3639,10 +3642,6 @@ package body Make is
Good_ALI.Init;
- if First_Q_Initialization then
- Init_Q;
- end if;
-
if Initialize_ALI_Data then
Initialize_ALI;
Initialize_ALI_Source;
@@ -3662,7 +3661,7 @@ package body Make is
-- compilations if -jnnn is used.
if not Is_Marked (Main_Source, Main_Index) then
- Insert_Q (Main_Source, Index => Main_Index);
+ Queue.Insert (Main_Source, Main_Project, Index => Main_Index);
Mark (Main_Source, Main_Index);
end if;
@@ -3674,7 +3673,8 @@ package body Make is
-- Keep looping until there is no more work to do (the Q is empty)
-- and all the outstanding compilations have terminated.
- Make_Loop : while not Empty_Q or else Outstanding_Compiles > 0 loop
+ Make_Loop :
+ while not Queue.Is_Empty or else Outstanding_Compiles > 0 loop
exit Make_Loop when Must_Exit_Because_Of_Error;
exit Make_Loop when Start_Compile_If_Possible (Args);
@@ -3687,11 +3687,11 @@ package body Make is
if Display_Compilation_Progress then
Write_Str ("completed ");
- Write_Int (Int (Q_Front));
+ Write_Int (Int (Queue.Processed));
Write_Str (" out of ");
- Write_Int (Int (Q.Last));
+ Write_Int (Int (Queue.Size));
Write_Str (" (");
- Write_Int (Int ((Q_Front * 100) / (Q.Last - Q.First)));
+ Write_Int (Int ((Queue.Processed * 100) / Queue.Size));
Write_Str ("%)...");
Write_Eol;
end if;
@@ -4052,29 +4052,6 @@ package body Make is
Display_Executed_Programs := Display;
end Display_Commands;
- -------------
- -- Empty_Q --
- -------------
-
- function Empty_Q return Boolean is
- begin
- if Debug.Debug_Flag_P then
- Write_Str (" Q := [");
-
- for J in Q_Front .. Q.Last - 1 loop
- Write_Str (" ");
- Write_Name (Q.Table (J).File);
- Write_Eol;
- Write_Str (" ");
- end loop;
-
- Write_Str ("]");
- Write_Eol;
- end if;
-
- return Q_Front >= Q.Last;
- end Empty_Q;
-
--------------------------
-- Enter_Into_Obsoleted --
--------------------------
@@ -4106,39 +4083,6 @@ package body Make is
Obsoleted.Set (F2, True);
end Enter_Into_Obsoleted;
- --------------------
- -- Extract_From_Q --
- --------------------
-
- procedure Extract_From_Q
- (Source_File : out File_Name_Type;
- Source_Unit : out Unit_Name_Type;
- Source_Index : out Int)
- is
- File : constant File_Name_Type := Q.Table (Q_Front).File;
- Unit : constant Unit_Name_Type := Q.Table (Q_Front).Unit;
- Index : constant Int := Q.Table (Q_Front).Index;
-
- begin
- if Debug.Debug_Flag_Q then
- Write_Str (" Q := Q - [ ");
- Write_Name (File);
-
- if Index /= 0 then
- Write_Str (", ");
- Write_Int (Index);
- end if;
-
- Write_Str (" ]");
- Write_Eol;
- end if;
-
- Q_Front := Q_Front + 1;
- Source_File := File;
- Source_Unit := Unit;
- Source_Index := Index;
- end Extract_From_Q;
-
--------------
-- Gnatmake --
--------------
@@ -4575,10 +4519,10 @@ package body Make is
Add_Switch ("-n", Binder, And_Save => True);
- for J in Q.First .. Q.Last - 1 loop
+ for J in 1 .. Queue.Size loop
Add_Switch
(Get_Name_String
- (Lib_File_Name (Q.Table (J).File)),
+ (Lib_File_Name (Queue.Element (J))),
Binder, And_Save => True);
end loop;
end if;
@@ -5595,6 +5539,10 @@ package body Make is
Args (J) := Gcc_Switches.Table (J);
end loop;
+ Queue.Initialize
+ (Main_Project /= No_Project and then
+ One_Compilation_Per_Obj_Dir);
+
-- Now we invoke Compile_Sources for the current main
Compile_Sources
@@ -5619,10 +5567,6 @@ package body Make is
Write_Eol;
end if;
- -- Make sure the queue will be reinitialized for the next round
-
- First_Q_Initialization := True;
-
Total_Compilation_Failures :=
Total_Compilation_Failures + Compilation_Failures;
@@ -6688,17 +6632,6 @@ package body Make is
File_Index := Data.Last_Mapping_File_Names;
end Init_Mapping_File;
- ------------
- -- Init_Q --
- ------------
-
- procedure Init_Q is
- begin
- First_Q_Initialization := False;
- Q_Front := Q.First;
- Q.Set_Last (Q.First);
- end Init_Q;
-
----------------
-- Initialize --
----------------
@@ -6969,6 +6902,7 @@ package body Make is
Unit : Unit_Index;
Sfile : File_Name_Type;
Index : Int;
+ Project : Project_Id;
Extending : constant Boolean := The_Project.Extends /= No_Project;
@@ -7010,8 +6944,9 @@ package body Make is
Unit := Units_Htable.Get_First (Project_Tree.Units_HT);
while Unit /= null loop
- Sfile := No_File;
- Index := 0;
+ Sfile := No_File;
+ Index := 0;
+ Project := No_Project;
-- If there is a source for the body, and the body has not been
-- locally removed.
@@ -7022,6 +6957,7 @@ package body Make is
-- And it is a source for the specified project
if Check_Project (Unit.File_Names (Impl).Project) then
+ Project := Unit.File_Names (Impl).Project;
-- If we don't have a spec, we cannot consider the source
-- if it is a subunit.
@@ -7072,38 +7008,36 @@ package body Make is
Sfile := Unit.File_Names (Spec).Display_File;
Index := Unit.File_Names (Spec).Index;
+ Project := Unit.File_Names (Spec).Project;
end if;
- -- If Put_In_Q is True, we insert into the Q
+ -- For the first source inserted into the Q, we need to initialize
+ -- the Q, but not for the subsequent sources.
- if Put_In_Q then
+ Queue.Initialize
+ (Main_Project /= No_Project and then
+ One_Compilation_Per_Obj_Dir);
- -- For the first source inserted into the Q, we need to initialize
- -- the Q, but not for the subsequent sources.
+ -- And of course, only insert in the Q if the source is not marked
- if First_Q_Initialization then
- Init_Q;
+ if Sfile /= No_File and then not Is_Marked (Sfile, Index) then
+ if Verbose_Mode then
+ Write_Str ("Adding """);
+ Write_Str (Get_Name_String (Sfile));
+ Write_Line (""" to the queue");
end if;
- -- And of course, only insert in the Q if the source is not marked
-
- if Sfile /= No_File and then not Is_Marked (Sfile, Index) then
- if Verbose_Mode then
- Write_Str ("Adding """);
- Write_Str (Get_Name_String (Sfile));
- Write_Line (""" to the queue");
- end if;
-
- Insert_Q (Sfile, Index => Index);
- Mark (Sfile, Index);
- end if;
+ Queue.Insert (Sfile, Project, Index => Index);
+ Mark (Sfile, Index);
+ end if;
- elsif Sfile /= No_File then
+ if not Put_In_Q and then Sfile /= No_File then
-- If Put_In_Q is False, we add the source as if it were specified
-- on the command line, and we set Put_In_Q to True, so that the
- -- following sources will be put directly in the queue. This will
- -- allow parallel compilation processes if -jx switch is used.
+ -- following sources will only be put in the queue. The source is
+ -- aready in the Q, but we need at least one fake main to call
+ -- Compile_Sources.
if Verbose_Mode then
Write_Str ("Adding """);
@@ -7113,49 +7047,12 @@ package body Make is
Osint.Add_File (Get_Name_String (Sfile), Index);
Put_In_Q := True;
-
- -- As we may look into the Q later, ensure the Q has been
- -- initialized to avoid errors.
-
- if First_Q_Initialization then
- Init_Q;
- end if;
end if;
Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
end loop;
end Insert_Project_Sources;
- --------------
- -- Insert_Q --
- --------------
-
- procedure Insert_Q
- (Source_File : File_Name_Type;
- Source_Unit : Unit_Name_Type := No_Unit_Name;
- Index : Int := 0)
- is
- begin
- if Debug.Debug_Flag_Q then
- Write_Str (" Q := Q + [ ");
- Write_Name (Source_File);
-
- if Index /= 0 then
- Write_Str (", ");
- Write_Int (Index);
- end if;
-
- Write_Str (" ] ");
- Write_Eol;
- end if;
-
- Q.Table (Q.Last) :=
- (File => Source_File,
- Unit => Source_Unit,
- Index => Index);
- Q.Increment_Last;
- end Insert_Q;
-
---------------------
-- Is_In_Obsoleted --
---------------------
@@ -7568,6 +7465,290 @@ package body Make is
(Project_Node_Tree, "--RTS=" & Line (1 .. N_Read), And_Save => True);
end Process_Multilib;
+ -----------
+ -- Queue --
+ -----------
+
+ package body Queue is
+
+ type Q_Record is record
+ File : File_Name_Type;
+ Unit : Unit_Name_Type;
+ Index : Int;
+ Project : Project_Id;
+ Processed : Boolean;
+ end record;
+ -- File is the name of the file to compile. Unit is for gnatdist use in
+ -- order to easily get the unit name of a file to compile when its name
+ -- is krunched or declared in gnat.adc. Index, when not 0, is the index
+ -- of the unit in a multi-unit source.
+
+ package Q is new Table.Table
+ (Table_Component_Type => Q_Record,
+ Table_Index_Type => Positive,
+ Table_Low_Bound => 1,
+ Table_Initial => 4000,
+ Table_Increment => 100,
+ Table_Name => "Make.Queue.Q");
+ -- This is the actual Q
+
+ package Busy_Obj_Dirs is new GNAT.HTable.Simple_HTable
+ (Header_Num => Prj.Header_Num,
+ Element => Boolean,
+ No_Element => False,
+ Key => Path_Name_Type,
+ Hash => Hash,
+ Equal => "=");
+
+ Q_First : Natural := 1;
+ -- Points to the first valid element in the queue
+
+ Q_Processed : Natural := 0;
+ One_Queue_Per_Obj_Dir : Boolean := False;
+ Q_Initialized : Boolean := False;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Rank : Positive) return File_Name_Type is
+ begin
+ if Rank <= Q.Last then
+ return Q.Table (Rank).File;
+ else
+ return No_File;
+ end if;
+ end Element;
+
+ -------------
+ -- Extract --
+ -------------
+
+ -- This body needs commenting ???
+
+ procedure Extract
+ (Source_File_Name : out File_Name_Type;
+ Source_Unit : out Unit_Name_Type;
+ Source_Index : out Int)
+ is
+ Found : Boolean := False;
+
+ begin
+ if One_Queue_Per_Obj_Dir then
+ for J in Q_First .. Q.Last loop
+ if not Q.Table (J).Processed
+ and then (Q.Table (J).Project = No_Project
+ or else not
+ Busy_Obj_Dirs.Get
+ (Q.Table (J).Project.Object_Directory.Name))
+ then
+ Found := True;
+ Source_File_Name := Q.Table (J).File;
+ Source_Unit := Q.Table (J).Unit;
+ Source_Index := Q.Table (J).Index;
+ Q.Table (J).Processed := True;
+
+ if J = Q_First then
+ while Q_First <= Q.Last
+ and then Q.Table (Q_First).Processed
+ loop
+ Q_First := Q_First + 1;
+ end loop;
+ end if;
+
+ exit;
+ end if;
+ end loop;
+
+ elsif Q_First <= Q.Last then
+ Source_File_Name := Q.Table (Q_First).File;
+ Source_Unit := Q.Table (Q_First).Unit;
+ Source_Index := Q.Table (Q_First).Index;
+ Q.Table (Q_First).Processed := True;
+ Q_First := Q_First + 1;
+ Found := True;
+ end if;
+
+ if Found then
+ Q_Processed := Q_Processed + 1;
+ else
+ Source_File_Name := No_File;
+ Source_Unit := No_Unit_Name;
+ Source_Index := 0;
+ end if;
+
+ if Found and then Debug.Debug_Flag_Q then
+ Write_Str (" Q := Q - [ ");
+ Write_Name (Source_File_Name);
+
+ if Source_Index /= 0 then
+ Write_Str (", ");
+ Write_Int (Source_Index);
+ end if;
+
+ Write_Str (" ]");
+ Write_Eol;
+
+ Write_Str (" Q_First =");
+ Write_Int (Int (Q_First));
+ Write_Eol;
+
+ Write_Str (" Q.Last =");
+ Write_Int (Int (Q.Last));
+ Write_Eol;
+ end if;
+ end Extract;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Queue_Per_Obj_Dir : Boolean) is
+ begin
+ if not Q_Initialized then
+ One_Queue_Per_Obj_Dir := Queue_Per_Obj_Dir;
+ Q.Init;
+ Q_Initialized := True;
+ Q_Processed := 0;
+ Q_First := 1;
+ end if;
+ end Initialize;
+
+ ------------
+ -- Insert --
+ ------------
+
+ -- This body needs commenting ???
+
+ procedure Insert
+ (Source_File_Name : File_Name_Type;
+ Project : Project_Id;
+ Source_Unit : Unit_Name_Type := No_Unit_Name;
+ Index : Int := 0)
+ is
+ begin
+ Q.Append
+ ((File => Source_File_Name,
+ Project => Project,
+ Unit => Source_Unit,
+ Index => Index,
+ Processed => False));
+
+ if Debug.Debug_Flag_Q then
+ Write_Str (" Q := Q + [ ");
+ Write_Name (Source_File_Name);
+
+ if Index /= 0 then
+ Write_Str (", ");
+ Write_Int (Index);
+ end if;
+
+ Write_Str (" ] ");
+ Write_Eol;
+
+ Write_Str (" Q_First =");
+ Write_Int (Int (Q_First));
+ Write_Eol;
+
+ Write_Str (" Q.Last =");
+ Write_Int (Int (Q.Last));
+ Write_Eol;
+ end if;
+ end Insert;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty return Boolean is
+ begin
+ if Debug.Debug_Flag_P then
+ Write_Str (" Q := [");
+
+ for J in Q_First .. Q.Last loop
+ if not Q.Table (J).Processed then
+ Write_Str (" ");
+ Write_Name (Q.Table (J).File);
+ Write_Eol;
+ Write_Str (" ");
+ end if;
+ end loop;
+
+ Write_Str ("]");
+ Write_Eol;
+ end if;
+
+ return Q_First > Q.Last;
+ end Is_Empty;
+
+ ------------------------
+ -- Is_Virtually_Empty --
+ ------------------------
+
+ function Is_Virtually_Empty return Boolean is
+ begin
+ if One_Queue_Per_Obj_Dir then
+ for J in Q_First .. Q.Last loop
+ if not Q.Table (J).Processed
+ and then
+ (Q.Table (J).Project = No_Project
+ or else not
+ Busy_Obj_Dirs.Get
+ (Q.Table (J).Project.Object_Directory.Name))
+ then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+
+ else
+ return Is_Empty;
+ end if;
+ end Is_Virtually_Empty;
+
+ ---------------
+ -- Processed --
+ ---------------
+
+ function Processed return Natural is
+ begin
+ return Q_Processed;
+ end Processed;
+
+ ----------------------
+ -- Set_Obj_Dir_Busy --
+ ----------------------
+
+ procedure Set_Obj_Dir_Busy (Obj_Dir : Path_Name_Type) is
+ begin
+ if One_Queue_Per_Obj_Dir then
+ Busy_Obj_Dirs.Set (Obj_Dir, True);
+ end if;
+ end Set_Obj_Dir_Busy;
+
+ ----------------------
+ -- Set_Obj_Dir_Free --
+ ----------------------
+
+ procedure Set_Obj_Dir_Free (Obj_Dir : Path_Name_Type) is
+ begin
+ if One_Queue_Per_Obj_Dir then
+ Busy_Obj_Dirs.Set (Obj_Dir, False);
+ end if;
+ end Set_Obj_Dir_Free;
+
+ ----------
+ -- Size --
+ ----------
+
+ function Size return Natural is
+ begin
+ return Q.Last;
+ end Size;
+
+ end Queue;
+
-----------------------------
-- Recursive_Compute_Depth --
-----------------------------
Index: makeutl.ads
===================================================================
--- makeutl.ads (revision 164000)
+++ makeutl.ads (working copy)
@@ -52,6 +52,11 @@ package Makeutl is
-- Command line switch to allow shared library projects to import projects
-- that are not shared library projects.
+ Single_Compile_Per_Obj_Dir_Switch : constant String :=
+ "--single-compile-per-obj-dir";
+ -- Switch to forbid simultaneous compilations for the same object directory
+ -- when project files are used.
+
procedure Add
(Option : String_Access;
To : in out String_List_Access;
Index: opt.ads
===================================================================
--- opt.ads (revision 164000)
+++ opt.ads (working copy)
@@ -910,6 +910,12 @@ package Opt is
-- GNATMAKE
-- Set to True when an object directory is specified with option -D
+ One_Compilation_Per_Obj_Dir : Boolean := False;
+ -- GNATMAKE, GPRBUILD
+ -- Set to True with switch --single-compile-per-obj-dir. When True, there
+ -- cannot be simultaneous compilations with the object files in the same
+ -- object directory, if project files are used.
+
type Operating_Mode_Type is (Check_Syntax, Check_Semantics, Generate_Code);
Operating_Mode : Operating_Mode_Type := Generate_Code;
-- GNAT
Index: switch-m.adb
===================================================================
--- switch-m.adb (revision 164000)
+++ switch-m.adb (working copy)
@@ -655,6 +655,9 @@ package body Switch.M is
elsif Switch_Chars = Makeutl.Unchecked_Shared_Lib_Imports then
Opt.Unchecked_Shared_Lib_Imports := True;
+ elsif Switch_Chars = Makeutl.Single_Compile_Per_Obj_Dir_Switch then
+ Opt.One_Compilation_Per_Obj_Dir := True;
+
elsif Switch_Chars (Ptr) = '-' then
Bad_Switch (Switch_Chars);
Index: vms_data.ads
===================================================================
--- vms_data.ads (revision 164058)
+++ vms_data.ads (working copy)
@@ -4858,6 +4858,9 @@ package VMS_Data is
--
-- Search the specified directories for both source and object files.
+ S_Make_Single : aliased constant S := "/SINGLE_COMPILE_PER_OBJ_DIR " &
+ "--single-compile-per-obj-dir";
+
S_Make_Skip : aliased constant S := "/SKIP_MISSING=*" &
"-aL*";
-- /SKIP_MISSING=(directory[,...])
@@ -4977,6 +4980,7 @@ package VMS_Data is
S_Make_Reason 'Access,
S_Make_RTS 'Access,
S_Make_Search 'Access,
+ S_Make_Single 'Access,
S_Make_Skip 'Access,
S_Make_Source 'Access,
S_Make_Stand 'Access,
More information about the Gcc-patches
mailing list