diff options
38 files changed, 1431 insertions, 216 deletions
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index eac13f7eacd..adeb6faf260 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -1,5 +1,5 @@ # Makefile.rtl for GNU Ada Compiler (GNAT). -# Copyright (C) 2003-2010, Free Software Foundation, Inc. +# Copyright (C) 2003-2011, Free Software Foundation, Inc. #This file is part of GCC. @@ -48,6 +48,7 @@ GNATRTL_TASKING_OBJS= \ s-inmaop$(objext) \ s-interr$(objext) \ s-intman$(objext) \ + s-mudido$(objext) \ s-oscons$(objext) \ s-osinte$(objext) \ s-proinf$(objext) \ diff --git a/gcc/ada/affinity.c b/gcc/ada/affinity.c new file mode 100644 index 00000000000..ffa4e688a04 --- /dev/null +++ b/gcc/ada/affinity.c @@ -0,0 +1,63 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * A F F I N I T Y * + * * + * C Implementation File * + * * + * Copyright (C) 2005-2011, Free Software Foundation, Inc. * + * * + * GNAT 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 2, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * 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, write * + * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * + * Boston, MA 02110-1301, USA. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* VxWorks SMP CPU affinity */ + +#include "taskLib.h" +#include "cpuset.h" + +extern int __gnat_set_affinity (int tid, unsigned cpu); +extern int __gnat_set_affinity_mask (int tid, unsigned mask); + +int + __gnat_set_affinity (int tid, unsigned cpu) +{ + cpuset_t cpuset; + + CPUSET_ZERO(cpuset); + CPUSET_SET(cpuset, cpu); + return taskCpuAffinitySet (tid, cpuset); +} + +int +__gnat_set_affinity_mask (int tid, unsigned mask) +{ + cpuset_t cpuset; + + CPUSET_ZERO(cpuset); + + for (index = 0; index < sizeof (unsigned) * 8; index++) + if (mask & (1 << index)) + CPUSET_SET(cpuset, index); + + return taskCpuAffinitySet (tid, cpuset); +} diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 2a161fad534..618e9cec18c 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -71,6 +71,13 @@ package body Bindgen is -- to do this unconditionally, since it drags in the System.Restrictions -- unit unconditionally, which is unpleasand, especially for ZFP etc.) + Dispatching_Domains_Used : Boolean; + -- Flag indicating whether multiprocessor dispatching domains are used in + -- the closure of the partition. This is set by + -- Check_Dispatching_Domains_Used, and is used to call the routine to + -- disallow the creation of new dispatching domains just before calling + -- the main procedure from the environment task. + Lib_Final_Built : Boolean := False; -- Flag indicating whether the finalize_library rountine has been built @@ -233,10 +240,19 @@ package body Bindgen is -- Local Subprograms -- ----------------------- + procedure Check_File_In_Partition (File_Name : String; Flag : out Boolean); + -- If the file indicated by File_Name is in the partition the Flag is set + -- to True, False otherwise. + procedure Check_System_Restrictions_Used; -- Sets flag System_Restrictions_Used (Set to True if and only if the unit -- System.Restrictions is present in the partition, otherwise False). + procedure Check_Dispatching_Domains_Used; + -- Sets flag Dispatching_Domains_Used to True when using the unit + -- System.Multiprocessors.Dispatching_Domains is present in the partition, + -- otherwise set to False. + procedure Gen_Adainit; -- Generates the Adainit procedure @@ -372,19 +388,38 @@ package body Bindgen is -- contents of statement buffer up to Last, and reset Last to 0 ------------------------------------ - -- Check_System_Restrictions_Used -- + -- Check_Dispatching_Domains_Used -- ------------------------------------ - procedure Check_System_Restrictions_Used is + procedure Check_Dispatching_Domains_Used is + begin + Check_File_In_Partition ("s-mudido.ads", Dispatching_Domains_Used); + end Check_Dispatching_Domains_Used; + + ----------------------------- + -- Check_File_In_Partition -- + ----------------------------- + + procedure Check_File_In_Partition + (File_Name : String; Flag : out Boolean) is begin for J in Units.First .. Units.Last loop - if Get_Name_String (Units.Table (J).Sfile) = "s-restri.ads" then - System_Restrictions_Used := True; + if Get_Name_String (Units.Table (J).Sfile) = File_Name then + Flag := True; return; end if; end loop; - System_Restrictions_Used := False; + Flag := False; + end Check_File_In_Partition; + + ------------------------------------ + -- Check_System_Restrictions_Used -- + ------------------------------------ + + procedure Check_System_Restrictions_Used is + begin + Check_File_In_Partition ("s-restri.ads", System_Restrictions_Used); end Check_System_Restrictions_Used; ------------------ @@ -664,6 +699,16 @@ package body Bindgen is & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len)) & """);"); end if; + -- When dispatching domains are used then we need to signal it + -- before calling the main procedure. + + if Dispatching_Domains_Used then + WBI (" procedure Freeze_Dispatching_Domains;"); + WBI (" pragma Import"); + WBI (" (Ada, Freeze_Dispatching_Domains, " & + """__gnat_freeze_dispatching_domains"");"); + end if; + WBI (" begin"); WBI (" if Is_Elaborated then"); WBI (" return;"); @@ -900,6 +945,12 @@ package body Bindgen is Gen_Elab_Calls; + -- From this point, no new dispatching domain can be created. + + if Dispatching_Domains_Used then + WBI (" Freeze_Dispatching_Domains;"); + end if; + -- Case of main program is CIL function or procedure if VM_Target = CLI_Target @@ -2037,6 +2088,7 @@ package body Bindgen is -- Generate output file in appropriate language Check_System_Restrictions_Used; + Check_Dispatching_Domains_Used; Gen_Output_File_Ada (Filename); end Gen_Output_File; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index e2aff220529..5e8bf7d0a78 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -7764,11 +7764,6 @@ package body Exp_Ch4 is Statements => New_List (Test), End_Label => Empty)); - -- The components of the scheme have already been analyzed, and the loop - -- parameter declaration has been processed. - - Set_Analyzed (Iteration_Scheme (Last (Actions))); - Rewrite (N, Make_Expression_With_Actions (Loc, Expression => New_Occurrence_Of (Tnn, Loc), diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index dbe238b3a63..47af37ff649 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2956,14 +2956,17 @@ package body Exp_Ch5 is -- Processing for containers else - -- For an iterator of the form "Of" then name is some expression, - -- which is transformed into a call to the default iterator. + -- For an "of" iterator the name is a container expression, which + -- is transformed into a call to the default iterator. - -- For an iterator of the form "in" then name is a function call - -- that delivers an iterator. + -- For an iterator of the form "in" the name is a function call + -- that delivers an iterator type. + + -- In both cases, analysis of the iterator has introduced an object + -- declaration to capture the domain, so that Container is an entity. -- The for loop is expanded into a while loop which uses a container - -- specific cursor to examine each element. + -- specific cursor to desgnate each element. -- Iter : Iterator_Type := Container.Iterate; -- Cursor : Cursor_type := First (Iter); @@ -2997,15 +3000,20 @@ package body Exp_Ch5 is -- The type of the iterator is the return type of the Iterate -- function used. For the "of" form this is the default iterator -- for the type, otherwise it is the type of the explicit - -- function used in the loop. + -- function used in the iterator specification. The most common + -- case will be an Iterate function in the container package. - Iter_Type := Etype (Name (I_Spec)); + -- The primitive operations of the container type may not be + -- use-visible, so we introduce the name of the enclosing package + -- in the declarations below. The Iterator type is declared in a + -- an instance within the container package itself. - if Is_Entity_Name (Container) then - Pack := Scope (Etype (Container)); + Iter_Type := Etype (Name (I_Spec)); + if Is_Iterator (Iter_Type) then + Pack := Scope (Scope (Etype (Container))); else - Pack := Scope (Entity (Name (Container))); + Pack := Scope (Etype (Container)); end if; -- The "of" case uses an internally generated cursor whose type @@ -3047,8 +3055,6 @@ package body Exp_Ch5 is Container_Arg := New_Copy_Tree (Container); else - Pack := Scope (Default_Iter); - Container_Arg := Make_Type_Conversion (Loc, Subtype_Mark => @@ -3195,9 +3201,12 @@ package body Exp_Ch5 is End_Label => Empty); -- Create the declarations for Iterator and cursor and insert then - -- before the source loop. Generate: + -- before the source loop. Given that the domain of iteration is + -- already an entity, the iterator is just a renaming of that + -- entity. Possible optimization ??? + -- Generate: - -- I : Iterator_Type := Iterate (Container); + -- I : Iterator_Type renames Container; -- C : Pack.Cursor_Type := Container.[First | Last]; declare @@ -3206,11 +3215,10 @@ package body Exp_Ch5 is begin Decl1 := - Make_Object_Declaration (Loc, + Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Iterator, - Object_Definition => New_Occurrence_Of (Iter_Type, Loc), - Expression => Relocate_Node (Name (I_Spec))); - Set_Assignment_OK (Decl1); + Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc), + Name => Relocate_Node (Name (I_Spec))); Decl2 := Make_Object_Declaration (Loc, @@ -3225,8 +3233,7 @@ package body Exp_Ch5 is Set_Assignment_OK (Decl2); - Insert_Actions (N, - New_List (Decl1, Decl2)); + Insert_Actions (N, New_List (Decl1, Decl2)); end; -- The Iterator is not modified in the source, but of course will diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index f2758ae125b..85b4024df8c 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -91,6 +91,12 @@ package body Ch4 is -- prefix. The current token is known to be an apostrophe and the -- following token is known to be RANGE. + function P_Unparen_Cond_Case_Quant_Expression return Node_Id; + -- This function is called with Token pointing to IF, CASE, or FOR, in a + -- context that allows a case, conditional, or quantified expression if + -- it is surrounded by parentheses. If not surrounded by parentheses, the + -- expression is still returned, but an error message is issued. + ------------------------- -- Bad_Range_Attribute -- ------------------------- @@ -470,8 +476,8 @@ package body Ch4 is end if; end if; - -- We come here with an OK attribute scanned, and the - -- corresponding Attribute identifier node stored in Ident_Node. + -- We come here with an OK attribute scanned, and corresponding + -- Attribute identifier node stored in Ident_Node. Prefix_Node := Name_Node; Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr); @@ -658,7 +664,7 @@ package body Ch4 is Error_Msg ("expect identifier in parameter association", Sloc (Expr_Node)); - Scan; -- past arrow + Scan; -- past arrow elsif not Comma_Present then T_Right_Paren; @@ -1640,18 +1646,18 @@ package body Ch4 is -- This function is identical to the normal P_Expression, except that it -- also permits the appearance of a case, conditional, or quantified - -- expression without the usual surrounding parentheses. + -- expression if the call immediately follows a left paren, and followed + -- by a right parenthesis. These forms are allowed if these conditions + -- are not met, but an error message will be issued. function P_Expression_If_OK return Node_Id is begin - if Token = Tok_Case then - return P_Case_Expression; + -- Case of conditional, case or quantified expression - elsif Token = Tok_If then - return P_Conditional_Expression; + if Token = Tok_Case or else Token = Tok_If or else Token = Tok_For then + return P_Unparen_Cond_Case_Quant_Expression; - elsif Token = Tok_For then - return P_Quantified_Expression; + -- Normal case, not case/conditional/quantified expression else return P_Expression; @@ -1749,18 +1755,18 @@ package body Ch4 is end P_Expression_Or_Range_Attribute; -- Version that allows a non-parenthesized case, conditional, or quantified - -- expression + -- expression if the call immediately follows a left paren, and followed + -- by a right parenthesis. These forms are allowed if these conditions + -- are not met, but an error message will be issued. function P_Expression_Or_Range_Attribute_If_OK return Node_Id is begin - if Token = Tok_Case then - return P_Case_Expression; + -- Case of conditional, case or quantified expression - elsif Token = Tok_If then - return P_Conditional_Expression; + if Token = Tok_Case or else Token = Tok_If or else Token = Tok_For then + return P_Unparen_Cond_Case_Quant_Expression; - elsif Token = Tok_For then - return P_Quantified_Expression; + -- Normal case, not one of the above expression types else return P_Expression_Or_Range_Attribute; @@ -3059,4 +3065,54 @@ package body Ch4 is end if; end P_Membership_Test; + ------------------------------------------ + -- P_Unparen_Cond_Case_Quant_Expression -- + ------------------------------------------ + + function P_Unparen_Cond_Case_Quant_Expression return Node_Id is + Lparen : constant Boolean := Prev_Token = Tok_Left_Paren; + Result : Node_Id; + + begin + -- Case expression + + if Token = Tok_Case then + Result := P_Case_Expression; + + if not (Lparen and then Token = Tok_Right_Paren) then + Error_Msg_N + ("case expression must be parenthesized!", Result); + end if; + + -- Conditional expression + + elsif Token = Tok_If then + Result := P_Conditional_Expression; + + if not (Lparen and then Token = Tok_Right_Paren) then + Error_Msg_N + ("conditional expression must be parenthesized!", Result); + end if; + + -- Quantified expression + + elsif Token = Tok_For then + Result := P_Quantified_Expression; + + if not (Lparen and then Token = Tok_Right_Paren) then + Error_Msg_N + ("quantified expression must be parenthesized!", Result); + end if; + + -- No other possibility should exist (caller was supposed to check) + + else + raise Program_Error; + end if; + + -- Return expression (possibly after having given message) + + return Result; + end P_Unparen_Cond_Case_Quant_Expression; + end Ch4; diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 39b8387fb36..0dbb7d988a7 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -691,8 +691,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- semicolon or comma, but does not consume this terminating token. function P_Expression_If_OK return Node_Id; - -- Scans out an expression in a context where a conditional expression - -- is permitted to appear without surrounding parentheses. + -- Scans out an expression allowing an unparenthesized case expression, + -- conditional expression, or quantified expression to appear without + -- enclosing parentheses. However, if such an expression is not preceded + -- by a left paren, and followed by a right paren, an error message will + -- be output noting that parenthesization is required. function P_Expression_No_Right_Paren return Node_Id; -- Scans out an expression in contexts where the expression cannot be @@ -702,6 +705,9 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is function P_Expression_Or_Range_Attribute_If_OK return Node_Id; -- Scans out an expression or range attribute where a conditional -- expression is permitted to appear without surrounding parentheses. + -- However, if such an expression is not preceded by a left paren, and + -- followed by a right paren, an error message will be output noting + -- that parenthesization is required. function P_Qualified_Expression (Subtype_Mark : Node_Id) return Node_Id; -- This routine scans out a qualified expression when the caller has diff --git a/gcc/ada/s-mudido-affinity.adb b/gcc/ada/s-mudido-affinity.adb new file mode 100644 index 00000000000..1c1d865eab7 --- /dev/null +++ b/gcc/ada/s-mudido-affinity.adb @@ -0,0 +1,396 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- 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 -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Body used on targets where the operating system supports setting task +-- affinities. + +with System.Tasking.Initialization; +with System.Task_Primitives.Operations; use System.Task_Primitives.Operations; + +with Ada.Unchecked_Conversion; + +package body System.Multiprocessors.Dispatching_Domains is + + package ST renames System.Tasking; + + ---------------- + -- Local data -- + ---------------- + + Dispatching_Domain_Tasks : + array (CPU'First .. Number_Of_CPUs) of Natural := (others => 0); + -- We need to store whether there are tasks allocated to concrete + -- processors in the default system dispatching domain because we need to + -- check it before creating a new dispatching domain. + -- ??? Tasks allocated with pragma CPU are not taken into account here. + + Dispatching_Domains_Frozen : Boolean := False; + -- True when the main procedure has been called. Hence, no new dispatching + -- domains can be created when this flag is True. + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Convert_Ids is new + Ada.Unchecked_Conversion (Ada.Task_Identification.Task_Id, ST.Task_Id); + + procedure Unchecked_Set_Affinity + (Domain : ST.Dispatching_Domain_Access; + CPU : CPU_Range; + T : ST.Task_Id); + -- Internal procedure to move a task to a target domain and CPU. No checks + -- are performed about the validity of the domain and the CPU because they + -- are done by the callers of this procedure (either Assign_Task or + -- Set_CPU). + + procedure Freeze_Dispatching_Domains; + pragma Export + (Ada, Freeze_Dispatching_Domains, "__gnat_freeze_dispatching_domains"); + -- Signal the time when no new dispatching domains can be created. It + -- should be called before the environment task calls the main procedure + -- (and after the elaboration code), so the binder-generated file needs to + -- import and call this procedure. + + ----------------- + -- Assign_Task -- + ----------------- + + procedure Assign_Task + (Domain : in out Dispatching_Domain; + CPU : CPU_Range := Not_A_Specific_CPU; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + is + Target : constant ST.Task_Id := Convert_Ids (T); + + use type System.Tasking.Dispatching_Domain_Access; + + begin + -- The exception Dispatching_Domain_Error is propagated if T is already + -- assigned to a Dispatching_Domain other than + -- System_Dispatching_Domain, or if CPU is not one of the processors of + -- Domain (and is not Not_A_Specific_CPU). + + if Target.Common.Domain /= null and then + Dispatching_Domain (Target.Common.Domain) /= System_Dispatching_Domain + then + raise Dispatching_Domain_Error with + "task already in user-defined dispatching domain"; + + elsif CPU /= Not_A_Specific_CPU and then CPU not in Domain'Range then + raise Dispatching_Domain_Error with + "processor does not belong to dispatching domain"; + end if; + + -- Assigning a task to System_Dispatching_Domain that is already + -- assigned to that domain has no effect. + + if Domain = System_Dispatching_Domain then + return; + + else + -- Set the task affinity once we know it is possible + + Unchecked_Set_Affinity + (ST.Dispatching_Domain_Access (Domain), CPU, Target); + end if; + end Assign_Task; + + ------------ + -- Create -- + ------------ + + function Create (First, Last : CPU) return Dispatching_Domain is + use type System.Tasking.Dispatching_Domain; + use type System.Tasking.Dispatching_Domain_Access; + use type System.Tasking.Task_Id; + + Valid_System_Domain : constant Boolean := + (First > CPU'First and then + not (System_Dispatching_Domain (CPU'First .. First - 1) = + (CPU'First .. First - 1 => False))) + or else + (Last < Number_Of_CPUs and then + not (System_Dispatching_Domain (Last + 1 .. Number_Of_CPUs) = + (Last + 1 .. Number_Of_CPUs => False))); + -- Constant that indicates whether there would exist a non-empty system + -- dispatching domain after the creation of this dispatching domain. + + T : ST.Task_Id; + + New_Domain : Dispatching_Domain; + + begin + -- The range of processors for creating a dispatching domain must + -- comply with the following restrictions: + -- - Non-empty range + -- - Not exceeding the range of available processors + -- - Range from the System_Dispatching_Domain + -- - Range does not contain a processor with a task assigned to it + -- - The allocation cannot leave System_Dispatching_Domain empty + -- - The calling task must be the environment task + -- - The call to Create must take place before the call to the main + -- subprogram + + if First > Last then + raise Dispatching_Domain_Error with "empty dispatching domain"; + + elsif Last > Number_Of_CPUs then + raise Dispatching_Domain_Error with + "CPU range not supported by the target"; + + elsif + System_Dispatching_Domain (First .. Last) /= (First .. Last => True) + then + raise Dispatching_Domain_Error with + "CPU range not currently in System_Dispatching_Domain"; + + elsif + Dispatching_Domain_Tasks (First .. Last) /= (First .. Last => 0) + then + raise Dispatching_Domain_Error with "CPU range has tasks assigned"; + + elsif not Valid_System_Domain then + raise Dispatching_Domain_Error with + "would leave System_Dispatching_Domain empty"; + + elsif Self /= Environment_Task then + raise Dispatching_Domain_Error with + "only the environment task can create dispatching domains"; + + elsif Dispatching_Domains_Frozen then + raise Dispatching_Domain_Error with + "cannot create dispatching domain after call to main program"; + end if; + + New_Domain := new ST.Dispatching_Domain'(First .. Last => True); + + -- At this point we need to fix the processors belonging to the system + -- domain, and change the affinity of every task that has been created + -- and assigned to the system domain. + + ST.Initialization.Defer_Abort (Self); + + Lock_RTS; + + System_Dispatching_Domain (First .. Last) := (First .. Last => False); + + -- Iterate the list of tasks belonging to the default system + -- dispatching domain and set the appropriate affinity. + + T := ST.All_Tasks_List; + + while T /= null loop + if T.Common.Domain = null or else + T.Common.Domain = ST.System_Domain + then + Set_Task_Affinity (T); + end if; + + T := T.Common.All_Tasks_Link; + end loop; + + Unlock_RTS; + + ST.Initialization.Undefer_Abort (Self); + + return New_Domain; + end Create; + + ----------------------------- + -- Delay_Until_And_Set_CPU -- + ----------------------------- + + procedure Delay_Until_And_Set_CPU + (Delay_Until_Time : Ada.Real_Time.Time; CPU : CPU_Range) is + begin + -- Not supported atomically by the underlying operating systems. + -- Operating systems use to migrate the task immediately after the call + -- to set the affinity. + + delay until Delay_Until_Time; + Set_CPU (CPU); + end Delay_Until_And_Set_CPU; + + -------------------------------- + -- Freeze_Dispatching_Domains -- + -------------------------------- + + procedure Freeze_Dispatching_Domains is + begin + -- Signal the end of the elaboration code + + Dispatching_Domains_Frozen := True; + end Freeze_Dispatching_Domains; + + ------------- + -- Get_CPU -- + ------------- + + function Get_CPU + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + return CPU_Range is + begin + return Convert_Ids (T).Common.Base_CPU; + end Get_CPU; + + ---------------------------- + -- Get_Dispatching_Domain -- + ---------------------------- + + function Get_Dispatching_Domain + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + return Dispatching_Domain is + begin + return Dispatching_Domain (Convert_Ids (T).Common.Domain); + end Get_Dispatching_Domain; + + ------------------- + -- Get_First_CPU -- + ------------------- + + function Get_First_CPU (Domain : Dispatching_Domain) return CPU is + begin + for Proc in Domain'Range loop + if Domain (Proc) then + return Proc; + end if; + end loop; + + -- Should never reach the following return + + return Domain'First; + end Get_First_CPU; + + ------------------ + -- Get_Last_CPU -- + ------------------ + + function Get_Last_CPU (Domain : Dispatching_Domain) return CPU is + begin + for Proc in reverse Domain'Range loop + if Domain (Proc) then + return Proc; + end if; + end loop; + + -- Should never reach the following return + + return Domain'Last; + end Get_Last_CPU; + + ------------- + -- Set_CPU -- + ------------- + + procedure Set_CPU + (CPU : CPU_Range; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + is + Target : constant ST.Task_Id := Convert_Ids (T); + + use type ST.Dispatching_Domain_Access; + + begin + -- The exception Dispatching_Domain_Error is propagated if CPU is not + -- one of the processors of the Dispatching_Domain on which T is + -- assigned (and is not Not_A_Specific_CPU). + + if CPU /= Not_A_Specific_CPU and then + (CPU not in Target.Common.Domain'Range or else + not Target.Common.Domain (CPU)) + then + raise Dispatching_Domain_Error with + "CPU does not belong to the task's dispatching domain"; + end if; + + Unchecked_Set_Affinity (Target.Common.Domain, CPU, Target); + end Set_CPU; + + ---------------------------- + -- Unchecked_Set_Affinity -- + ---------------------------- + + procedure Unchecked_Set_Affinity + (Domain : ST.Dispatching_Domain_Access; + CPU : CPU_Range; + T : ST.Task_Id) + is + Source_CPU : constant CPU_Range := T.Common.Base_CPU; + + use type System.Tasking.Dispatching_Domain_Access; + + begin + Write_Lock (T); + + -- Move to the new domain + + T.Common.Domain := Domain; + + -- Attach the CPU to the task + + T.Common.Base_CPU := CPU; + + -- Change the number of tasks attached to a given task in the system + -- domain if needed. + + if not Dispatching_Domains_Frozen and then + (Domain = null or else Domain = ST.System_Domain) + then + -- Reduce the number of tasks attached to the CPU from which this + -- task is being moved, if needed. + + if Source_CPU /= Not_A_Specific_CPU then + Dispatching_Domain_Tasks (Source_CPU) := + Dispatching_Domain_Tasks (Source_CPU) - 1; + end if; + + -- Increase the number of tasks attached to the CPU to which this + -- task is being moved, if needed. + + if CPU /= Not_A_Specific_CPU then + Dispatching_Domain_Tasks (CPU) := + Dispatching_Domain_Tasks (CPU) + 1; + end if; + end if; + + -- Change the actual affinity calling the operating system level + + Set_Task_Affinity (T); + + Unlock (T); + end Unchecked_Set_Affinity; + +end System.Multiprocessors.Dispatching_Domains; diff --git a/gcc/ada/s-mudido.adb b/gcc/ada/s-mudido.adb new file mode 100644 index 00000000000..caba7422b4b --- /dev/null +++ b/gcc/ada/s-mudido.adb @@ -0,0 +1,166 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- 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 -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Body used on unimplemented targets, where the operating system does not +-- support setting task affinities. + +package body System.Multiprocessors.Dispatching_Domains is + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Freeze_Dispatching_Domains; + pragma Export + (Ada, Freeze_Dispatching_Domains, "__gnat_freeze_dispatching_domains"); + -- Signal the time when no new dispatching domains can be created. It + -- should be called before the environment task calls the main procedure + -- (and after the elaboration code), so the binder-generated file needs to + -- import and call this procedure. + + ----------------- + -- Assign_Task -- + ----------------- + + procedure Assign_Task + (Domain : in out Dispatching_Domain; + CPU : CPU_Range := Not_A_Specific_CPU; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + is + pragma Unreferenced (Domain, CPU, T); + + begin + raise Dispatching_Domain_Error with "dispatching domains not supported"; + end Assign_Task; + + ------------ + -- Create -- + ------------ + + function Create (First, Last : CPU) return Dispatching_Domain is + pragma Unreferenced (First, Last); + + begin + raise Dispatching_Domain_Error with "dispatching domains not supported"; + return System_Dispatching_Domain; + end Create; + + ----------------------------- + -- Delay_Until_And_Set_CPU -- + ----------------------------- + + procedure Delay_Until_And_Set_CPU + (Delay_Until_Time : Ada.Real_Time.Time; CPU : CPU_Range) + is + pragma Unreferenced (Delay_Until_Time, CPU); + + begin + raise Dispatching_Domain_Error with "dispatching domains not supported"; + end Delay_Until_And_Set_CPU; + + -------------------------------- + -- Freeze_Dispatching_Domains -- + -------------------------------- + + procedure Freeze_Dispatching_Domains is + begin + null; + end Freeze_Dispatching_Domains; + + ------------- + -- Get_CPU -- + ------------- + + function Get_CPU + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + return CPU_Range + is + pragma Unreferenced (T); + + begin + return Not_A_Specific_CPU; + end Get_CPU; + + ---------------------------- + -- Get_Dispatching_Domain -- + ---------------------------- + + function Get_Dispatching_Domain + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + return Dispatching_Domain + is + pragma Unreferenced (T); + + begin + return System_Dispatching_Domain; + end Get_Dispatching_Domain; + + ------------------- + -- Get_First_CPU -- + ------------------- + + function Get_First_CPU (Domain : Dispatching_Domain) return CPU is + pragma Unreferenced (Domain); + + begin + return CPU'First; + end Get_First_CPU; + + ------------------ + -- Get_Last_CPU -- + ------------------ + + function Get_Last_CPU (Domain : Dispatching_Domain) return CPU is + pragma Unreferenced (Domain); + + begin + return Number_Of_CPUs; + end Get_Last_CPU; + + ------------- + -- Set_CPU -- + ------------- + + procedure Set_CPU + (CPU : CPU_Range; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + is + pragma Unreferenced (CPU, T); + + begin + raise Dispatching_Domain_Error with "dispatching domains not supported"; + end Set_CPU; + +end System.Multiprocessors.Dispatching_Domains; diff --git a/gcc/ada/s-mudido.ads b/gcc/ada/s-mudido.ads new file mode 100644 index 00000000000..62cc01d72c4 --- /dev/null +++ b/gcc/ada/s-mudido.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Real_Time; + +with Ada.Task_Identification; + +private with System.Tasking; + +package System.Multiprocessors.Dispatching_Domains is + -- pragma Preelaborate (Dispatching_Domains); + -- ??? According to AI 167 this unit should be preelaborate, but it cannot + -- be preelaborate because it depends on Ada.Real_Time which is not + -- preelaborate. + + Dispatching_Domain_Error : exception; + + type Dispatching_Domain (<>) is limited private; + + System_Dispatching_Domain : constant Dispatching_Domain; + + function Create (First, Last : CPU) return Dispatching_Domain; + + function Get_First_CPU (Domain : Dispatching_Domain) return CPU; + + function Get_Last_CPU (Domain : Dispatching_Domain) return CPU; + + function Get_Dispatching_Domain + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + return Dispatching_Domain; + + procedure Assign_Task + (Domain : in out Dispatching_Domain; + CPU : CPU_Range := Not_A_Specific_CPU; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task); + + procedure Set_CPU + (CPU : CPU_Range; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task); + + function Get_CPU + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + return CPU_Range; + + procedure Delay_Until_And_Set_CPU + (Delay_Until_Time : Ada.Real_Time.Time; CPU : CPU_Range); + +private + type Dispatching_Domain is new System.Tasking.Dispatching_Domain_Access; + + System_Dispatching_Domain : constant Dispatching_Domain := + Dispatching_Domain (System.Tasking.System_Domain); +end System.Multiprocessors.Dispatching_Domains; diff --git a/gcc/ada/s-osinte-solaris.ads b/gcc/ada/s-osinte-solaris.ads index 12c5b4fe654..03a0c4ae47d 100644 --- a/gcc/ada/s-osinte-solaris.ads +++ b/gcc/ada/s-osinte-solaris.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2011, Free Software Foundation, Inc. -- -- -- -- GNAT 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- -- @@ -492,6 +492,24 @@ package System.OS_Interface is obind : processorid_t_ptr) return int; pragma Import (C, processor_bind, "processor_bind"); + type psetid_t is new int; + + function pset_create (pset : access psetid_t) return int; + pragma Import (C, pset_create, "pset_create"); + + function pset_assign + (pset : psetid_t; + proc_id : processorid_t; + opset : access psetid_t) return int; + pragma Import (C, pset_assign, "pset_assign"); + + function pset_bind + (pset : psetid_t; + id_type : int; + id : id_t; + opset : access psetid_t) return int; + pragma Import (C, pset_bind, "pset_bind"); + procedure pthread_init; -- Dummy procedure to share s-intman.adb with other Solaris targets diff --git a/gcc/ada/s-osinte-vxworks.ads b/gcc/ada/s-osinte-vxworks.ads index 384e1e02f25..f5013ea6977 100644 --- a/gcc/ada/s-osinte-vxworks.ads +++ b/gcc/ada/s-osinte-vxworks.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2011, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -47,6 +47,7 @@ package System.OS_Interface is pragma Preelaborate; subtype int is Interfaces.C.int; + subtype unsigned is Interfaces.C.unsigned; subtype short is Short_Integer; type unsigned_int is mod 2 ** int'Size; type long is new Long_Integer; @@ -493,6 +494,11 @@ package System.OS_Interface is -- For SMP run-times the affinity to CPU. -- For uniprocessor systems return ERROR status. + function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int + renames System.VxWorks.Ext.taskMaskAffinitySet; + -- For SMP run-times the affinity to CPU_Set. + -- For uniprocessor systems return ERROR status. + --------------------- -- Multiprocessors -- --------------------- diff --git a/gcc/ada/s-taprop-dummy.adb b/gcc/ada/s-taprop-dummy.adb index 645e9fd90ba..88f4571f61e 100644 --- a/gcc/ada/s-taprop-dummy.adb +++ b/gcc/ada/s-taprop-dummy.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -346,6 +346,15 @@ package body System.Task_Primitives.Operations is null; end Set_Priority; + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + begin + null; + end Set_Task_Affinity; + -------------- -- Set_True -- -------------- diff --git a/gcc/ada/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb index 164034ec881..ca059c95408 100644 --- a/gcc/ada/s-taprop-hpux-dce.adb +++ b/gcc/ada/s-taprop-hpux-dce.adb @@ -1241,4 +1241,16 @@ package body System.Task_Primitives.Operations is -- this difference is that sigwait doesn't work when some critical -- signals (SIGABRT, SIGPIPE) are masked. + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + pragma Unreferenced (T); + begin + -- Setting task affinity is not supported by the underlying system + + null; + end Set_Task_Affinity; + end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb index 9d8ac90b59c..9eb766c7145 100644 --- a/gcc/ada/s-taprop-irix.adb +++ b/gcc/ada/s-taprop-irix.adb @@ -1342,4 +1342,16 @@ package body System.Task_Primitives.Operations is end if; end Initialize; + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + pragma Unreferenced (T); + begin + -- Setting task affinity is not supported by the underlying system + + null; + end Set_Task_Affinity; + end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index f46736fbf5f..7296ca18969 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -879,6 +879,27 @@ package body System.Task_Primitives.Operations is CPU_SETSIZE / 8, T.Common.Task_Info.CPU_Affinity'Access); pragma Assert (Result = 0); + + -- Handle dispatching domains + + elsif T.Common.Domain /= null then + declare + CPU_Set : aliased cpu_set_t := (bits => (others => False)); + begin + -- Set the affinity to all the processors belonging to the + -- dispatching domain. + + for Proc in T.Common.Domain'Range loop + CPU_Set.bits (Integer (Proc)) := T.Common.Domain (Proc); + end loop; + + Result := + pthread_attr_setaffinity_np + (Attributes'Access, + CPU_SETSIZE / 8, + CPU_Set'Access); + pragma Assert (Result = 0); + end; end if; -- Since the initial signal mask of a thread is inherited from the @@ -1328,24 +1349,78 @@ package body System.Task_Primitives.Operations is Abort_Handler_Installed := True; end if; - -- pragma CPU for the environment task + -- pragma CPU and dispatching domains for the environment task - if pthread_setaffinity_np'Address /= System.Null_Address - and then Environment_Task.Common.Base_CPU /= - System.Multiprocessors.Not_A_Specific_CPU - then + Set_Task_Affinity (Environment_Task); + end Initialize; + + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + use type System.Multiprocessors.CPU_Range; + + begin + if pthread_setaffinity_np'Address /= System.Null_Address then declare - CPU_Set : aliased cpu_set_t := (bits => (others => False)); + CPU_Set : access cpu_set_t := null; + + Result : Interfaces.C.int; + begin - CPU_Set.bits (Integer (Environment_Task.Common.Base_CPU)) := True; - Result := - pthread_setaffinity_np - (Environment_Task.Common.LL.Thread, - CPU_SETSIZE / 8, - CPU_Set'Access); - pragma Assert (Result = 0); + -- We look at the specific CPU (Base_CPU) first, then at the + -- Task_Info field, and finally at the assigned dispatching + -- domain, if any. + + if T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then + -- Set the affinity to an unique CPU + + CPU_Set := new cpu_set_t'(bits => (others => False)); + CPU_Set.bits (Integer (T.Common.Base_CPU)) := True; + + -- Handle Task_Info + + elsif T.Common.Task_Info /= null + and then T.Common.Task_Info.CPU_Affinity /= Task_Info.Any_CPU + then + CPU_Set := T.Common.Task_Info.CPU_Affinity'Access; + + -- Handle dispatching domains + + elsif T.Common.Domain /= null and then + (T.Common.Domain /= ST.System_Domain or else + T.Common.Domain.all /= (Multiprocessors.CPU'First .. + Multiprocessors.Number_Of_CPUs => True)) + then + -- Set the affinity to all the processors belonging to the + -- dispatching domain. To avoid changing CPU affinities when + -- not needed, we set the affinity only when assigning to a + -- domain other than the default one, or when the default one + -- has been modified. + + CPU_Set := new cpu_set_t'(bits => (others => False)); + + for Proc in T.Common.Domain'Range loop + CPU_Set.bits (Integer (Proc)) := T.Common.Domain (Proc); + end loop; + end if; + + -- We set the new affinity if needed. Otherwise, the new task + -- will inherit its creator's CPU affinity mask (according to + -- the documentation of pthread_setaffinity_np), which is + -- consistent with Ada's required semantics. + + if CPU_Set /= null then + Result := + pthread_setaffinity_np + (T.Common.LL.Thread, + CPU_SETSIZE / 8, + CPU_Set); + pragma Assert (Result = 0); + end if; end; end if; - end Initialize; + end Set_Task_Affinity; end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index cbde1f4c90e..a770a6a4589 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -954,21 +954,7 @@ package body System.Task_Primitives.Operations is -- Step 4: Handle pragma CPU and Task_Info - if T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then - - -- The CPU numbering in pragma CPU starts at 1 while the subprogram - -- to set the affinity starts at 0, therefore we must subtract 1. - - Result := SetThreadIdealProcessor - (hTask, ProcessorId (T.Common.Base_CPU) - 1); - pragma Assert (Result = 1); - - elsif T.Common.Task_Info /= null then - if T.Common.Task_Info.CPU /= Task_Info.Any_CPU then - Result := SetThreadIdealProcessor (hTask, T.Common.Task_Info.CPU); - pragma Assert (Result = 1); - end if; - end if; + Set_Task_Affinity (T); -- Step 5: Now, start it for good @@ -1074,10 +1060,6 @@ package body System.Task_Primitives.Operations is Discard : BOOL; pragma Unreferenced (Discard); - Result : DWORD; - - use type System.Multiprocessors.CPU_Range; - begin Environment_Task_Id := Environment_Task; OS_Primitives.Initialize; @@ -1109,20 +1091,9 @@ package body System.Task_Primitives.Operations is Enter_Task (Environment_Task); - -- pragma CPU for the environment task - - if Environment_Task.Common.Base_CPU /= - System.Multiprocessors.Not_A_Specific_CPU - then - -- The CPU numbering in pragma CPU starts at 1 while the subprogram - -- to set the affinity starts at 0, therefore we must subtract 1. + -- pragma CPU and dispatching domains for the environment task - Result := - SetThreadIdealProcessor - (Environment_Task.Common.LL.Thread, - ProcessorId (Environment_Task.Common.Base_CPU) - 1); - pragma Assert (Result = 1); - end if; + Set_Task_Affinity (Environment_Task); end Initialize; --------------------- @@ -1377,4 +1348,61 @@ package body System.Task_Primitives.Operations is return False; end Continue_Task; + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + Result : DWORD; + + use type System.Multiprocessors.CPU_Range; + + begin + -- pragma CPU + + if T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then + + -- The CPU numbering in pragma CPU starts at 1 while the subprogram + -- to set the affinity starts at 0, therefore we must substract 1. + + Result := SetThreadIdealProcessor + (T.Common.LL.Thread, ProcessorId (T.Common.Base_CPU) - 1); + pragma Assert (Result = 1); + + -- Task_Info + + elsif T.Common.Task_Info /= null then + if T.Common.Task_Info.CPU /= Task_Info.Any_CPU then + Result := + SetThreadIdealProcessor + (T.Common.LL.Thread, T.Common.Task_Info.CPU); + pragma Assert (Result = 1); + end if; + + -- Dispatching domains + + elsif T.Common.Domain /= null and then + (T.Common.Domain /= ST.System_Domain or else + T.Common.Domain.all /= (Multiprocessors.CPU'First .. + Multiprocessors.Number_Of_CPUs => True)) + then + declare + CPU_Set : DWORD := 0; + + begin + for Proc in T.Common.Domain'Range loop + if T.Common.Domain (Proc) then + -- The thread affinity mask is a bit vector in which each + -- bit represents a logical processor. + + CPU_Set := CPU_Set + 2 ** (Integer (Proc) - 1); + end if; + end loop; + + Result := SetThreadAffinityMask (T.Common.LL.Thread, CPU_Set); + pragma Assert (Result = 1); + end; + end if; + end Set_Task_Affinity; + end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index 2372d3d9b29..b367915d147 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.adb @@ -1449,4 +1449,16 @@ package body System.Task_Primitives.Operations is end if; end Initialize; + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + pragma Unreferenced (T); + begin + -- Setting task affinity is not supported by the underlying system + + null; + end Set_Task_Affinity; + end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb index 042a9312326..31862fa10bd 100644 --- a/gcc/ada/s-taprop-solaris.adb +++ b/gcc/ada/s-taprop-solaris.adb @@ -862,68 +862,12 @@ package body System.Task_Primitives.Operations is ---------------- procedure Enter_Task (Self_ID : Task_Id) is - Result : Interfaces.C.int; - Proc : processorid_t; -- User processor # - Last_Proc : processorid_t; -- Last processor # - - use System.Task_Info; - use type System.Multiprocessors.CPU_Range; - begin Self_ID.Common.LL.Thread := thr_self; Self_ID.Common.LL.LWP := lwp_self; - -- pragma CPU - - if Self_ID.Common.Base_CPU /= - System.Multiprocessors.Not_A_Specific_CPU - then - -- The CPU numbering in pragma CPU starts at 1 while the subprogram - -- to set the affinity starts at 0, therefore we must subtract 1. - - Result := - processor_bind - (P_LWPID, P_MYID, processorid_t (Self_ID.Common.Base_CPU) - 1, - null); - pragma Assert (Result = 0); - - -- Task_Info - - elsif Self_ID.Common.Task_Info /= null then - if Self_ID.Common.Task_Info.New_LWP - and then Self_ID.Common.Task_Info.CPU /= CPU_UNCHANGED - then - Last_Proc := Num_Procs - 1; - - if Self_ID.Common.Task_Info.CPU = ANY_CPU then - Result := 0; - Proc := 0; - while Proc < Last_Proc loop - Result := p_online (Proc, PR_STATUS); - exit when Result = PR_ONLINE; - Proc := Proc + 1; - end loop; - - Result := processor_bind (P_LWPID, P_MYID, Proc, null); - pragma Assert (Result = 0); - - else - -- Use specified processor - - if Self_ID.Common.Task_Info.CPU < 0 - or else Self_ID.Common.Task_Info.CPU > Last_Proc - then - raise Invalid_CPU_Number; - end if; - - Result := - processor_bind - (P_LWPID, P_MYID, Self_ID.Common.Task_Info.CPU, null); - pragma Assert (Result = 0); - end if; - end if; - end if; + Set_Task_Affinity (Self_ID); Specific.Set (Self_ID); @@ -1987,4 +1931,107 @@ package body System.Task_Primitives.Operations is return False; end Continue_Task; + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + Result : Interfaces.C.int; + Proc : processorid_t; -- User processor # + Last_Proc : processorid_t; -- Last processor # + + use System.Task_Info; + use type System.Multiprocessors.CPU_Range; + + begin + -- pragma CPU + + if T.Common.Base_CPU /= + System.Multiprocessors.Not_A_Specific_CPU + then + -- The CPU numbering in pragma CPU starts at 1 while the subprogram + -- to set the affinity starts at 0, therefore we must substract 1. + + Result := + processor_bind + (P_LWPID, id_t (T.Common.LL.LWP), + processorid_t (T.Common.Base_CPU) - 1, null); + pragma Assert (Result = 0); + + -- Task_Info + + elsif T.Common.Task_Info /= null then + if T.Common.Task_Info.New_LWP + and then T.Common.Task_Info.CPU /= CPU_UNCHANGED + then + Last_Proc := Num_Procs - 1; + + if T.Common.Task_Info.CPU = ANY_CPU then + Result := 0; + Proc := 0; + while Proc < Last_Proc loop + Result := p_online (Proc, PR_STATUS); + exit when Result = PR_ONLINE; + Proc := Proc + 1; + end loop; + + Result := + processor_bind + (P_LWPID, id_t (T.Common.LL.LWP), Proc, null); + pragma Assert (Result = 0); + + else + -- Use specified processor + + if T.Common.Task_Info.CPU < 0 + or else T.Common.Task_Info.CPU > Last_Proc + then + raise Invalid_CPU_Number; + end if; + Result := + processor_bind + (P_LWPID, id_t (T.Common.LL.LWP), + T.Common.Task_Info.CPU, null); + pragma Assert (Result = 0); + end if; + end if; + + -- Handle dispatching domains + + elsif T.Common.Domain /= null and then + (T.Common.Domain /= ST.System_Domain or else + T.Common.Domain.all /= (Multiprocessors.CPU'First .. + Multiprocessors.Number_Of_CPUs => True)) + then + declare + CPU_Set : aliased psetid_t; + + Result : int; + + begin + Result := pset_create (CPU_Set'Access); + pragma Assert (Result = 0); + + -- Set the affinity to all the processors belonging to the + -- dispatching domain. + + for Proc in T.Common.Domain'Range loop + -- The Ada CPU numbering starts at 1 while the subprogram to + -- set the affinity starts at 0, therefore we must substract + -- 1. + + if T.Common.Domain (Proc) then + Result := + pset_assign (CPU_Set, processorid_t (Proc) - 1, null); + pragma Assert (Result = 0); + end if; + end loop; + + Result := + pset_bind (CPU_Set, P_LWPID, id_t (T.Common.LL.LWP), null); + pragma Assert (Result = 0); + end; + end if; + end Set_Task_Affinity; + end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb index 6c2c527fe11..55c4bd4c06f 100644 --- a/gcc/ada/s-taprop-tru64.adb +++ b/gcc/ada/s-taprop-tru64.adb @@ -1355,4 +1355,15 @@ package body System.Task_Primitives.Operations is end if; end Initialize; + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + pragma Unreferenced (T); + begin + -- Setting task affinity is not supported by the underlying system + + null; + end Set_Task_Affinity; end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb index 1759c5084c7..dbb84db4827 100644 --- a/gcc/ada/s-taprop-vms.adb +++ b/gcc/ada/s-taprop-vms.adb @@ -1254,4 +1254,15 @@ package body System.Task_Primitives.Operations is Enter_Task (Environment_Task); end Initialize; + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + pragma Unreferenced (T); + begin + -- Setting task affinity is not supported by the underlying system + + null; + end Set_Task_Affinity; end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index 0214efb63cc..b1c88f38388 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -67,8 +67,10 @@ package body System.Task_Primitives.Operations is use System.Parameters; use type System.VxWorks.Ext.t_id; use type Interfaces.C.int; + use type System.OS_Interface.unsigned; subtype int is System.OS_Interface.int; + subtype unsigned is System.OS_Interface.unsigned; Relative : constant := 0; @@ -883,10 +885,6 @@ package body System.Task_Primitives.Operations is Succeeded : out Boolean) is Adjusted_Stack_Size : size_t; - Result : int := 0; - - use System.Task_Info; - use type System.Multiprocessors.CPU_Range; begin -- Ask for four extra bytes of stack space so that the ATCB pointer can @@ -952,26 +950,9 @@ package body System.Task_Primitives.Operations is -- Set processor affinity - if T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then - -- Ada 2012 pragma CPU uses CPU numbers starting from 1, while - -- on VxWorks the first CPU is identified by a 0, so we need to - -- adjust. - - Result := - taskCpuAffinitySet - (T.Common.LL.Thread, int (T.Common.Base_CPU) - 1); + Set_Task_Affinity (T); - elsif T.Common.Task_Info /= Unspecified_Task_Info then - Result := - taskCpuAffinitySet (T.Common.LL.Thread, T.Common.Task_Info); - end if; - - if Result = -1 then - taskDelete (T.Common.LL.Thread); - T.Common.LL.Thread := -1; - end if; - - if T.Common.LL.Thread = -1 then + if T.Common.LL.Thread <= 0 then Succeeded := False; else Succeeded := True; @@ -1371,8 +1352,7 @@ package body System.Task_Primitives.Operations is procedure Initialize (Environment_Task : Task_Id) is Result : int; - - use type System.Multiprocessors.CPU_Range; + pragma Unreferenced (Result); begin Environment_Task_Id := Environment_Task; @@ -1413,19 +1393,64 @@ package body System.Task_Primitives.Operations is -- Set processor affinity - if Environment_Task.Common.Base_CPU /= - System.Multiprocessors.Not_A_Specific_CPU - then + Set_Task_Affinity (Environment_Task); + end Initialize; + + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + Result : int := 0; + pragma Unreferenced (Result); + + use System.Task_Info; + use type System.Multiprocessors.CPU_Range; + + begin + -- pragma CPU + + if T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then -- Ada 2012 pragma CPU uses CPU numbers starting from 1, while -- on VxWorks the first CPU is identified by a 0, so we need to -- adjust. Result := taskCpuAffinitySet - (Environment_Task.Common.LL.Thread, - int (Environment_Task.Common.Base_CPU) - 1); - pragma Assert (Result /= -1); + (T.Common.LL.Thread, int (T.Common.Base_CPU) - 1); + + -- Task_Info + + elsif T.Common.Task_Info /= Unspecified_Task_Info then + Result := + taskCpuAffinitySet (T.Common.LL.Thread, T.Common.Task_Info); + + -- Handle dispatching domains + + elsif T.Common.Domain /= null and then + (T.Common.Domain /= ST.System_Domain or else + T.Common.Domain.all /= (Multiprocessors.CPU'First .. + Multiprocessors.Number_Of_CPUs => True)) + then + declare + CPU_Set : unsigned := 0; + begin + -- Set the affinity to all the processors belonging to the + -- dispatching domain. + + for Proc in T.Common.Domain'Range loop + if T.Common.Domain (Proc) then + -- The thread affinity mask is a bit vector in which each + -- bit represents a logical processor. + + CPU_Set := CPU_Set + 2 ** (Integer (Proc) - 1); + end if; + end loop; + + Result := + taskMaskAffinitySet (T.Common.LL.Thread, CPU_Set); + end; end if; - end Initialize; + end Set_Task_Affinity; end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop.ads b/gcc/ada/s-taprop.ads index 5c571d41b69..e413b126645 100644 --- a/gcc/ada/s-taprop.ads +++ b/gcc/ada/s-taprop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -543,4 +543,12 @@ package System.Task_Primitives.Operations is -- such functionality. Such functionality is needed by gdb on some targets -- (e.g VxWorks) Return True is the operation is successful + ------------------- + -- Task affinity -- + ------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id); + -- Enforce at the operating system level the task affinity defined in the + -- Ada Task Control Block. + end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb index d2d29f9246e..c79171b23c3 100644 --- a/gcc/ada/s-taskin.adb +++ b/gcc/ada/s-taskin.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -218,6 +218,21 @@ package body System.Tasking is T.Common.Task_Image_Len := Main_Task_Image'Length; T.Common.Task_Image (Main_Task_Image'Range) := Main_Task_Image; + -- At program start-up the environment task is allocated to the default + -- system dispatching domain. + -- Make sure that the processors which are not available are not taken + -- into account. Use Number_Of_CPUs to know the exact number of + -- processors in the system at execution time. + + System_Domain := new Dispatching_Domain' + (Multiprocessors.CPU'First .. Multiprocessors.Number_Of_CPUs => True); + + T.Common.Domain := System_Domain; + + -- ??? If we want to handle the interaction between pragma CPU and + -- dispatching domains we would need to signal that this task is being + -- allocated to a processor. + -- Only initialize the first element since others are not relevant -- in ravenscar mode. Rest of the initialization is done in Init_RTS. diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index 971d4ee92ba..743ca586bbd 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -375,6 +375,29 @@ package System.Tasking is -- terminates. ------------------------------------ + -- Dispatching domain definitions -- + ------------------------------------ + + -- We need to redefine here these types (already defined in + -- System.Multiprocessor.Dispatching_Domains) for avoiding circular + -- dependencies. + + type Dispatching_Domain is + array (System.Multiprocessors.CPU range <>) of Boolean; + -- A dispatching domain needs to contain the set of processors belonging + -- to it. This is a processor mask where a True indicates that the + -- processor belongs to the dispatching domain. + -- Do not use the full range of CPU_Range because it would create a very + -- long array. This way we can use the exact range of processors available + -- in the system. + + type Dispatching_Domain_Access is access Dispatching_Domain; + + System_Domain : Dispatching_Domain_Access; + -- All processors belong to the default system dispatching domain at start + -- up. + + ------------------------------------ -- Task related other definitions -- ------------------------------------ @@ -637,6 +660,16 @@ package System.Tasking is Debug_Events : Debug_Event_Array; -- Word length array of per task debug events, of which 11 kinds are -- currently defined in System.Tasking.Debugging package. + + Domain : Dispatching_Domain_Access; + -- Domain is the dispatching domain to which the task belongs. It is + -- only changed via dispatching domains package. This field is made + -- part of the Common_ATCB, even when restricted run-times (namely + -- Ravenscar) do not use it, because this way the field is always + -- available to the underlying layers to set the affinity and we do not + -- need to do different things depending on the situation. + -- + -- Protection: Self.L end record; --------------------------------------- diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 74d522c985a..a071aa113a2 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -539,6 +539,10 @@ package body System.Tasking.Stages is else System.Multiprocessors.CPU_Range (CPU)); end if; + -- ??? If we want to handle the interaction between pragma CPU and + -- dispatching domains we would need to signal that this task is being + -- allocated to a processor. + -- Find parent P of new Task, via master level number P := Self_ID; @@ -638,6 +642,17 @@ package body System.Tasking.Stages is T.Common.Task_Image_Len := Len; end if; + -- ??? For the moment the task inherits the dispatching domain of the + -- parent. It will change when support for the Dispatching_Domain + -- aspect will be added, because that will allow setting the domain + -- in the spec of the task. + + if T.Common.Activator /= null then + T.Common.Domain := T.Common.Activator.Common.Domain; + else + T.Common.Domain := System.Tasking.System_Domain; + end if; + Unlock (Self_ID); Unlock_RTS; diff --git a/gcc/ada/s-vxwext-kernel.adb b/gcc/ada/s-vxwext-kernel.adb index d43edf15429..cd2ac264266 100644 --- a/gcc/ada/s-vxwext-kernel.adb +++ b/gcc/ada/s-vxwext-kernel.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2011, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -75,6 +75,16 @@ package body System.VxWorks.Ext is return ERROR; end taskCpuAffinitySet; + ------------------------- + -- taskMaskAffinitySet -- + ------------------------- + + function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is + pragma Unreferenced (tid, CPU_Set); + begin + return ERROR; + end taskMaskAffinitySet; + -------------- -- taskStop -- -------------- diff --git a/gcc/ada/s-vxwext-kernel.ads b/gcc/ada/s-vxwext-kernel.ads index 59dfee03ac7..ff41666fbed 100644 --- a/gcc/ada/s-vxwext-kernel.ads +++ b/gcc/ada/s-vxwext-kernel.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2011, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -43,6 +43,7 @@ package System.VxWorks.Ext is type t_id is new Long_Integer; subtype int is Interfaces.C.int; + subtype unsigned is Interfaces.C.unsigned; type Interrupt_Handler is access procedure (parameter : System.Address); pragma Convention (C, Interrupt_Handler); @@ -101,4 +102,9 @@ package System.VxWorks.Ext is -- For SMP run-times set the CPU affinity. -- For uniprocessor systems return ERROR status. + function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int; + pragma Convention (C, taskMaskAffinitySet); + -- For SMP run-times set the CPU mask affinity. + -- For uniprocessor systems return ERROR status. + end System.VxWorks.Ext; diff --git a/gcc/ada/s-vxwext-rtp.adb b/gcc/ada/s-vxwext-rtp.adb index 431f41e7499..e5f74062ca2 100644 --- a/gcc/ada/s-vxwext-rtp.adb +++ b/gcc/ada/s-vxwext-rtp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2011, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -121,4 +121,14 @@ package body System.VxWorks.Ext is return ERROR; end taskCpuAffinitySet; + ------------------------- + -- taskMaskAffinitySet -- + ------------------------- + + function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is + pragma Unreferenced (tid, CPU_Set); + begin + return ERROR; + end taskMaskAffinitySet; + end System.VxWorks.Ext; diff --git a/gcc/ada/s-vxwext-rtp.ads b/gcc/ada/s-vxwext-rtp.ads index f1783c9c22a..ed734578c0b 100644 --- a/gcc/ada/s-vxwext-rtp.ads +++ b/gcc/ada/s-vxwext-rtp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2011, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -43,6 +43,7 @@ package System.VxWorks.Ext is type t_id is new Long_Integer; subtype int is Interfaces.C.int; + subtype unsigned is Interfaces.C.unsigned; type Interrupt_Handler is access procedure (parameter : System.Address); pragma Convention (C, Interrupt_Handler); @@ -95,4 +96,9 @@ package System.VxWorks.Ext is -- For SMP run-times set the CPU affinity. -- For uniprocessor systems return ERROR status. + function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int; + pragma Convention (C, taskMaskAffinitySet); + -- For SMP run-times set the CPU mask affinity. + -- For uniprocessor systems return ERROR status. + end System.VxWorks.Ext; diff --git a/gcc/ada/s-vxwext.adb b/gcc/ada/s-vxwext.adb index cfc65da62b6..a386af91d0f 100644 --- a/gcc/ada/s-vxwext.adb +++ b/gcc/ada/s-vxwext.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2009-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- -- -- -- GNAT 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- -- @@ -42,4 +42,14 @@ package body System.VxWorks.Ext is return ERROR; end taskCpuAffinitySet; + ------------------------- + -- taskMaskAffinitySet -- + ------------------------- + + function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is + pragma Unreferenced (tid, CPU_Set); + begin + return ERROR; + end taskMaskAffinitySet; + end System.VxWorks.Ext; diff --git a/gcc/ada/s-vxwext.ads b/gcc/ada/s-vxwext.ads index f39ccbf3f63..6e7cd16331a 100644 --- a/gcc/ada/s-vxwext.ads +++ b/gcc/ada/s-vxwext.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2011, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -44,6 +44,7 @@ package System.VxWorks.Ext is type t_id is new Long_Integer; subtype int is Interfaces.C.int; + subtype unsigned is Interfaces.C.unsigned; type Interrupt_Handler is access procedure (parameter : System.Address); pragma Convention (C, Interrupt_Handler); @@ -96,4 +97,9 @@ package System.VxWorks.Ext is -- For SMP run-times set the CPU affinity. -- For uniprocessor systems return ERROR status. + function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int; + pragma Convention (C, taskMaskAffinitySet); + -- For SMP run-times set the CPU mask affinity. + -- For uniprocessor systems return ERROR status. + end System.VxWorks.Ext; diff --git a/gcc/ada/s-winext.ads b/gcc/ada/s-winext.ads index 22a7ab29ba0..803a6483ca4 100644 --- a/gcc/ada/s-winext.ads +++ b/gcc/ada/s-winext.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- -- -- -- GNAT 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- -- @@ -53,6 +53,11 @@ package System.Win32.Ext is dwIdealProcessor : ProcessorId) return DWORD; pragma Import (Stdcall, SetThreadIdealProcessor, "SetThreadIdealProcessor"); + function SetThreadAffinityMask + (hThread : HANDLE; + dwThreadAffinityMask : DWORD) return DWORD; + pragma Import (Stdcall, SetThreadAffinityMask, "SetThreadAffinityMask"); + -------------- -- Com Port -- -------------- diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index a926280b2a0..d0351d2cce1 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -3904,9 +3904,7 @@ package body Sem_Ch13 is -- This seems dubious, this destroys the source tree in a manner -- not detectable by ASIS ??? - if Operating_Mode = Check_Semantics - and then ASIS_Mode - then + if Operating_Mode = Check_Semantics and then ASIS_Mode then AtM_Nod := Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (Base_Type (Rectype), Loc), diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 62218c46e17..6ce88d7506c 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -30,7 +30,6 @@ with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Exp_Util; use Exp_Util; -with Expander; use Expander; with Fname; use Fname; with Itypes; use Itypes; with Lib; use Lib; @@ -3352,14 +3351,19 @@ package body Sem_Ch4 is Iterator : Node_Id; begin - -- Analyze construct with expansion disabled, because it will be - -- rewritten as a loop during expansion. + Set_Etype (Ent, Standard_Void_Type); + Set_Scope (Ent, Current_Scope); + Set_Parent (Ent, N); - Expander_Mode_Save_And_Set (False); Check_SPARK_Restriction ("quantified expression is not allowed", N); - Set_Etype (Ent, Standard_Void_Type); - Set_Parent (Ent, N); + -- If expansion is enabled, the condition is analyzed after rewritten + -- as a loop. Otherwise we only need to set the type. + + if Operating_Mode /= Check_Semantics then + Set_Etype (N, Standard_Boolean); + return; + end if; if Present (Loop_Parameter_Specification (N)) then Iterator := @@ -3390,7 +3394,6 @@ package body Sem_Ch4 is Analyze (Condition (N)); End_Scope; Set_Etype (N, Standard_Boolean); - Expander_Mode_Restore; end Analyze_Quantified_Expression; ------------------- diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 25710733a1b..b576ba818d0 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2250,15 +2250,11 @@ package body Sem_Ch5 is Analyze (Subt); end if; - -- If it is an expression, the name is pre-analyzed in the caller. - -- If it it of a controlled type we need a block for the finalization - -- actions. As for loop bounds that need finalization, we create a - -- declaration and an assignment to trigger these actions. - - if Present (Etype (Iter_Name)) - and then Is_Controlled (Etype (Iter_Name)) - and then not Is_Entity_Name (Iter_Name) - then + -- If the domain of iteration is an expression, create a declaration + -- for it, so that finalization actions are introduced outside of the + -- loop. + + if not Is_Entity_Name (Iter_Name) then declare Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 2b0bb029ad2..5e410990ff5 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8085,6 +8085,13 @@ package body Sem_Res is begin if not ALFA_Mode then + -- If expansion is enabled, analysis is delayed until the expresssion + -- is rewritten as a loop. + + if Operating_Mode /= Check_Semantics then + return; + end if; + -- The loop structure is already resolved during its analysis, only -- the resolution of the condition needs to be done. Expansion is -- disabled so that checks and other generated code are inserted in diff --git a/gcc/ada/vms_conv.adb b/gcc/ada/vms_conv.adb index 3f5421ee4d7..e0e29014751 100644 --- a/gcc/ada/vms_conv.adb +++ b/gcc/ada/vms_conv.adb @@ -1799,6 +1799,16 @@ package body VMS_Conv is (Arg (Arg'First .. SwP), Command.Switches, Quiet => False); + + -- Special case for GNAT COMPILE /UNCHECKED... + -- because the corresponding switch --unchecked... is + -- for gnatmake, not for the compiler. + + if Cargs and then + Sw.Name.all = "/UNCHECKED_SHARED_LIB_IMPORTS" + then + Cargs := False; + end if; end if; if Sw /= null then |