From patchwork Thu Sep 9 10:16:17 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 64277 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id ED8A3B6F06 for ; Thu, 9 Sep 2010 20:16:49 +1000 (EST) Received: (qmail 31166 invoked by alias); 9 Sep 2010 10:16:44 -0000 Received: (qmail 31123 invoked by uid 22791); 9 Sep 2010 10:16:34 -0000 X-SWARE-Spam-Status: No, hits=-1.7 required=5.0 tests=AWL, BAYES_00, TW_JN, TW_MX, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (212.99.106.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 09 Sep 2010 10:16:20 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id A835ECB027E; Thu, 9 Sep 2010 12:16:17 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id fQ3x7Q2fbGX1; Thu, 9 Sep 2010 12:16:17 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id 8F0D9CB025D; Thu, 9 Sep 2010 12:16:17 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 6F40AD9BA8; Thu, 9 Sep 2010 12:16:17 +0200 (CEST) Date: Thu, 9 Sep 2010 12:16:17 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Vincent Celier Subject: [Ada] Restrict simultaneous compilations to one per object dir Message-ID: <20100909101617.GA20426@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 * 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. 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,