Skip to content

R
riscv-gcc-1
Commit c37cbdc3 by Arnaud Charlet
Options

[multiple changes] 

2011-08-30  Jose Ruiz  <ruiz@adacore.com>

	* s-taskin.ads (Common_ATCB): Add field domain which contains the
	dispatching domain to which the task belongs.
	* s-taskin.adb (Initialize): Create the default system dispatching
	domain and make the environment task part of it.
	* s-mudido.ads: Add this new spec for standard Ada 2012 package
	Ada.Multiprocessors.Dispatching_Domains.
	* s-mudido.adb: Add this new body for targets not supporting
	dispatching domains.
	* s-mudido-affinity.adb: Add this new body for targets supporting
	dispatching domains setting the affinity to a CPU set.
	* bindgen.adb (Dispatching_Domain_Used, Check_Dispatching_Domains_Used,
	Gen_Adainit): When package System.Multiprocessors.Dispatching_Domains
	is used we call the procedure to signal that when we are about to call
	the main subprogram no new dispatching domain can be created.
	(Check_File_In_Partition): Factor out the common functionality used by
	Check_System_Restrictions_Used and Check_Dispatching_Domains_Used.
	* s-tassta.adb (Create_Task): Tasks inherit the dispatching domain of
	their activators.
	* s-taprop.ads (Set_Task_Affinity): Add this new procedure to set task
	affinities.
	* s-taprop-dummy.adb, s-taprop-hpux-dce.adb, s-taprop-irix.adb,
	s-taprop-posix.adb, s-taprop-tru64.adb, s-taprop-vms.adb
	(Set_Task_Affinity): Dummy null body for these targets not supporting
	task affinities.
	s-taprop-linux.adb, s-taprop-mingw.adb, s-taprop-solaris.adb,
	s-taprop-vxworks.adb (Create_Task, Enter_Task, Initialize): Handle
	dispatching domains and set the affinity of the environment task.
	(Set_Task_Affinity): Procedure that uses the underlying CPU set
	functionality to handle dispatching domains, pragma CPU and Task_Info.
	s-winext.ads (SetThreadAffinityMask): Import this function needed to
	set CPU masks.
	* s-osinte-solaris.ads (psetit_t, pset_create, pset_assign, pset_bind):
	Import the functionality to handle CPU set affinities.
	* affinity.c: New file.
	* s-osinte-vxworks.ads, s-vxwext.ads, s-vxwext-kernel.ads,
	s-vxwext-rtp.ads (taskMaskAffinitySet): Add this new spec for setting
	affinity masks.
	* s-vxwext.adb, s-vxwext-kernel.adb, s-vxwext-rtp.adb 
	(taskMaskAffinitySet): Body returning an error indicating that task
	affinities are not supported.
	Makefile.rtl: Indicate that s-mudido is part of libgnarl.
	* gcc-interface/Makefile.in (LIBGNAT_TARGET_PAIRS for VxWorks SMP,
	Solaris, Windows, and {x86,PowerPC, ia64,x86_64} Linux): Use the
	s-mudido-affinity.adb body which supports task affinities.

2011-08-30  Thomas quinot  <quinot@adacore.com>

	* sem_ch13.adb: Minor reformatting.

2011-08-30  Vincent Celier  <celier@adacore.com>

	* vms_conv.adb (Process_Argument): When the qualifier
	/UNCHECKED_SHARED_LIB_IMPORTS is for GNAT COMPILE, do not put the
	corresponding switch --unchecked-shared-lib-imports after -cargs, as it
	is for gnatmake, not for the compiler.

2011-08-30  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Analyze_Quantified_Expression): Analyze iterator
	specification and condition only in Semantics_Only mode. Otherwise the
	analysis is done after expression has been rewritten as loop.
	* sem_ch5.adb (Analyze_Iterator_Specification): Always generate a
	temporary for the iterator name (the domain of iteration) because it
	may need finalization actions and these must be generated outside of
	the loop.
	* sem_res.adb (Resolve_Quantified_Expression): Resolve only in
	Semantic_Only mode.
	* exp_ch4.adb (Expand_Quantified_Expression): Analyze and resolve once
	rewritten as loop.
	* exp_ch5.adb (Expand_Iterator_Loop): Code clean-up, now that the
	iterator is always an expression.

2011-08-30  Robert Dewar  <dewar@adacore.com>

	* par-ch4.adb (P_Unparen_Cond_Case_Quant_Expression): New function
	(P_Expression_If_OK): New spec checks parens
	(P_Expression_Or_Range_Attribute_If_OK): New spec checks parens
	* par.adb (P_Expression_If_OK): New spec checks parens
	(P_Expression_Or_Range_Attribute_If_OK): New spec checks parens

From-SVN: r178321
parent f8dd28d6
Showing with 1035 additions and 216 deletions
gcc/ada/Makefile.rtl
# Makefile.rtl for GNU Ada Compiler (GNAT). # 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. #This file is part of GCC.
...@@ -48,6 +48,7 @@ GNATRTL_TASKING_OBJS= \ ...@@ -48,6 +48,7 @@ GNATRTL_TASKING_OBJS= \
s-inmaop$(objext) \ s-inmaop$(objext) \
s-interr$(objext) \ s-interr$(objext) \
s-intman$(objext) \ s-intman$(objext) \
s-mudido$(objext) \
s-oscons$(objext) \ s-oscons$(objext) \
s-osinte$(objext) \ s-osinte$(objext) \
s-proinf$(objext) \ s-proinf$(objext) \
......
gcc/ada/affinity.c 0 → 100644
/****************************************************************************
* *
* 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);
}
gcc/ada/bindgen.adb
...@@ -71,6 +71,13 @@ package body Bindgen is ...@@ -71,6 +71,13 @@ package body Bindgen is
-- to do this unconditionally, since it drags in the System.Restrictions -- to do this unconditionally, since it drags in the System.Restrictions
-- unit unconditionally, which is unpleasand, especially for ZFP etc.) -- 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; Lib_Final_Built : Boolean := False;
-- Flag indicating whether the finalize_library rountine has been built -- Flag indicating whether the finalize_library rountine has been built
...@@ -233,10 +240,19 @@ package body Bindgen is ...@@ -233,10 +240,19 @@ package body Bindgen is
-- Local Subprograms -- -- 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; procedure Check_System_Restrictions_Used;
-- Sets flag System_Restrictions_Used (Set to True if and only if the unit -- Sets flag System_Restrictions_Used (Set to True if and only if the unit
-- System.Restrictions is present in the partition, otherwise False). -- 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; procedure Gen_Adainit;
-- Generates the Adainit procedure -- Generates the Adainit procedure
...@@ -372,19 +388,38 @@ package body Bindgen is ...@@ -372,19 +388,38 @@ package body Bindgen is
-- contents of statement buffer up to Last, and reset Last to 0 -- 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 begin
for J in Units.First .. Units.Last loop for J in Units.First .. Units.Last loop
if Get_Name_String (Units.Table (J).Sfile) = "s-restri.ads" then if Get_Name_String (Units.Table (J).Sfile) = File_Name then
System_Restrictions_Used := True; Flag := True;
return; return;
end if; end if;
end loop; 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; end Check_System_Restrictions_Used;
------------------ ------------------
...@@ -664,6 +699,16 @@ package body Bindgen is ...@@ -664,6 +699,16 @@ package body Bindgen is
& Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len)) & """);"); & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len)) & """);");
end if; 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 (" begin");
WBI (" if Is_Elaborated then"); WBI (" if Is_Elaborated then");
WBI (" return;"); WBI (" return;");
...@@ -900,6 +945,12 @@ package body Bindgen is ...@@ -900,6 +945,12 @@ package body Bindgen is
Gen_Elab_Calls; 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 -- Case of main program is CIL function or procedure
if VM_Target = CLI_Target if VM_Target = CLI_Target
...@@ -2037,6 +2088,7 @@ package body Bindgen is ...@@ -2037,6 +2088,7 @@ package body Bindgen is
-- Generate output file in appropriate language -- Generate output file in appropriate language
Check_System_Restrictions_Used; Check_System_Restrictions_Used;
Check_Dispatching_Domains_Used;
Gen_Output_File_Ada (Filename); Gen_Output_File_Ada (Filename);
end Gen_Output_File; end Gen_Output_File;
......
gcc/ada/exp_ch4.adb
...@@ -7764,11 +7764,6 @@ package body Exp_Ch4 is ...@@ -7764,11 +7764,6 @@ package body Exp_Ch4 is
Statements => New_List (Test), Statements => New_List (Test),
End_Label => Empty)); 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, Rewrite (N,
Make_Expression_With_Actions (Loc, Make_Expression_With_Actions (Loc,
Expression => New_Occurrence_Of (Tnn, Loc), Expression => New_Occurrence_Of (Tnn, Loc),
......
gcc/ada/exp_ch5.adb
...@@ -2956,14 +2956,17 @@ package body Exp_Ch5 is ...@@ -2956,14 +2956,17 @@ package body Exp_Ch5 is
-- Processing for containers -- Processing for containers
else else
-- For an iterator of the form "Of" then name is some expression, -- For an "of" iterator the name is a container expression, which
-- which is transformed into a call to the default iterator. -- is transformed into a call to the default iterator.
-- For an iterator of the form "in" then name is a function call -- For an iterator of the form "in" the name is a function call
-- that delivers an iterator. -- 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 -- 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; -- Iter : Iterator_Type := Container.Iterate;
-- Cursor : Cursor_type := First (Iter); -- Cursor : Cursor_type := First (Iter);
...@@ -2997,15 +3000,20 @@ package body Exp_Ch5 is ...@@ -2997,15 +3000,20 @@ package body Exp_Ch5 is
-- The type of the iterator is the return type of the Iterate -- The type of the iterator is the return type of the Iterate
-- function used. For the "of" form this is the default iterator -- function used. For the "of" form this is the default iterator
-- for the type, otherwise it is the type of the explicit -- 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 Iter_Type := Etype (Name (I_Spec));
Pack := Scope (Etype (Container));
if Is_Iterator (Iter_Type) then
Pack := Scope (Scope (Etype (Container)));
else else
Pack := Scope (Entity (Name (Container))); Pack := Scope (Etype (Container));
end if; end if;
-- The "of" case uses an internally generated cursor whose type -- The "of" case uses an internally generated cursor whose type
...@@ -3047,8 +3055,6 @@ package body Exp_Ch5 is ...@@ -3047,8 +3055,6 @@ package body Exp_Ch5 is
Container_Arg := New_Copy_Tree (Container); Container_Arg := New_Copy_Tree (Container);
else else
Pack := Scope (Default_Iter);
Container_Arg := Container_Arg :=
Make_Type_Conversion (Loc, Make_Type_Conversion (Loc,
Subtype_Mark => Subtype_Mark =>
...@@ -3195,9 +3201,12 @@ package body Exp_Ch5 is ...@@ -3195,9 +3201,12 @@ package body Exp_Ch5 is
End_Label => Empty); End_Label => Empty);
-- Create the declarations for Iterator and cursor and insert then -- 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]; -- C : Pack.Cursor_Type := Container.[First | Last];
declare declare
...@@ -3206,11 +3215,10 @@ package body Exp_Ch5 is ...@@ -3206,11 +3215,10 @@ package body Exp_Ch5 is
begin begin
Decl1 := Decl1 :=
Make_Object_Declaration (Loc, Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Iterator, Defining_Identifier => Iterator,
Object_Definition => New_Occurrence_Of (Iter_Type, Loc), Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc),
Expression => Relocate_Node (Name (I_Spec))); Name => Relocate_Node (Name (I_Spec)));
Set_Assignment_OK (Decl1);
Decl2 := Decl2 :=
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
...@@ -3225,8 +3233,7 @@ package body Exp_Ch5 is ...@@ -3225,8 +3233,7 @@ package body Exp_Ch5 is
Set_Assignment_OK (Decl2); Set_Assignment_OK (Decl2);
Insert_Actions (N, Insert_Actions (N, New_List (Decl1, Decl2));
New_List (Decl1, Decl2));
end; end;
-- The Iterator is not modified in the source, but of course will -- The Iterator is not modified in the source, but of course will
......
gcc/ada/par-ch4.adb
...@@ -91,6 +91,12 @@ package body Ch4 is ...@@ -91,6 +91,12 @@ package body Ch4 is
-- prefix. The current token is known to be an apostrophe and the -- prefix. The current token is known to be an apostrophe and the
-- following token is known to be RANGE. -- 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 -- -- Bad_Range_Attribute --
------------------------- -------------------------
...@@ -470,8 +476,8 @@ package body Ch4 is ...@@ -470,8 +476,8 @@ package body Ch4 is
end if; end if;
end if; end if;
-- We come here with an OK attribute scanned, and the -- We come here with an OK attribute scanned, and corresponding
-- corresponding Attribute identifier node stored in Ident_Node. -- Attribute identifier node stored in Ident_Node.
Prefix_Node := Name_Node; Prefix_Node := Name_Node;
Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr); Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr);
...@@ -658,7 +664,7 @@ package body Ch4 is ...@@ -658,7 +664,7 @@ package body Ch4 is
Error_Msg Error_Msg
("expect identifier in parameter association", ("expect identifier in parameter association",
Sloc (Expr_Node)); Sloc (Expr_Node));
Scan; -- past arrow Scan; -- past arrow
elsif not Comma_Present then elsif not Comma_Present then
T_Right_Paren; T_Right_Paren;
...@@ -1640,18 +1646,18 @@ package body Ch4 is ...@@ -1640,18 +1646,18 @@ package body Ch4 is
-- This function is identical to the normal P_Expression, except that it -- This function is identical to the normal P_Expression, except that it
-- also permits the appearance of a case, conditional, or quantified -- 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 function P_Expression_If_OK return Node_Id is
begin begin
if Token = Tok_Case then -- Case of conditional, case or quantified expression
return P_Case_Expression;
elsif Token = Tok_If then if Token = Tok_Case or else Token = Tok_If or else Token = Tok_For then
return P_Conditional_Expression; return P_Unparen_Cond_Case_Quant_Expression;
elsif Token = Tok_For then -- Normal case, not case/conditional/quantified expression
return P_Quantified_Expression;
else else
return P_Expression; return P_Expression;
...@@ -1749,18 +1755,18 @@ package body Ch4 is ...@@ -1749,18 +1755,18 @@ package body Ch4 is
end P_Expression_Or_Range_Attribute; end P_Expression_Or_Range_Attribute;
-- Version that allows a non-parenthesized case, conditional, or quantified -- 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 function P_Expression_Or_Range_Attribute_If_OK return Node_Id is
begin begin
if Token = Tok_Case then -- Case of conditional, case or quantified expression
return P_Case_Expression;
elsif Token = Tok_If then if Token = Tok_Case or else Token = Tok_If or else Token = Tok_For then
return P_Conditional_Expression; return P_Unparen_Cond_Case_Quant_Expression;
elsif Token = Tok_For then -- Normal case, not one of the above expression types
return P_Quantified_Expression;
else else
return P_Expression_Or_Range_Attribute; return P_Expression_Or_Range_Attribute;
...@@ -3059,4 +3065,54 @@ package body Ch4 is ...@@ -3059,4 +3065,54 @@ package body Ch4 is
end if; end if;
end P_Membership_Test; 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; end Ch4;
gcc/ada/par.adb
...@@ -691,8 +691,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is ...@@ -691,8 +691,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- semicolon or comma, but does not consume this terminating token. -- semicolon or comma, but does not consume this terminating token.
function P_Expression_If_OK return Node_Id; function P_Expression_If_OK return Node_Id;
-- Scans out an expression in a context where a conditional expression -- Scans out an expression allowing an unparenthesized case expression,
-- is permitted to appear without surrounding parentheses. -- 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; function P_Expression_No_Right_Paren return Node_Id;
-- Scans out an expression in contexts where the expression cannot be -- Scans out an expression in contexts where the expression cannot be
...@@ -702,6 +705,9 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is ...@@ -702,6 +705,9 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
function P_Expression_Or_Range_Attribute_If_OK return Node_Id; function P_Expression_Or_Range_Attribute_If_OK return Node_Id;
-- Scans out an expression or range attribute where a conditional -- Scans out an expression or range attribute where a conditional
-- expression is permitted to appear without surrounding parentheses. -- 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; function P_Qualified_Expression (Subtype_Mark : Node_Id) return Node_Id;
-- This routine scans out a qualified expression when the caller has -- This routine scans out a qualified expression when the caller has
......
gcc/ada/s-mudido.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/s-mudido.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/s-osinte-solaris.ads
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -492,6 +492,24 @@ package System.OS_Interface is ...@@ -492,6 +492,24 @@ package System.OS_Interface is
obind : processorid_t_ptr) return int; obind : processorid_t_ptr) return int;
pragma Import (C, processor_bind, "processor_bind"); 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; procedure pthread_init;
-- Dummy procedure to share s-intman.adb with other Solaris targets -- Dummy procedure to share s-intman.adb with other Solaris targets
......
gcc/ada/s-osinte-vxworks.ads
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -47,6 +47,7 @@ package System.OS_Interface is ...@@ -47,6 +47,7 @@ package System.OS_Interface is
pragma Preelaborate; pragma Preelaborate;
subtype int is Interfaces.C.int; subtype int is Interfaces.C.int;
subtype unsigned is Interfaces.C.unsigned;
subtype short is Short_Integer; subtype short is Short_Integer;
type unsigned_int is mod 2 ** int'Size; type unsigned_int is mod 2 ** int'Size;
type long is new Long_Integer; type long is new Long_Integer;
...@@ -493,6 +494,11 @@ package System.OS_Interface is ...@@ -493,6 +494,11 @@ package System.OS_Interface is
-- For SMP run-times the affinity to CPU. -- For SMP run-times the affinity to CPU.
-- For uniprocessor systems return ERROR status. -- 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 -- -- Multiprocessors --
--------------------- ---------------------
......
gcc/ada/s-taprop-dummy.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -346,6 +346,15 @@ package body System.Task_Primitives.Operations is ...@@ -346,6 +346,15 @@ package body System.Task_Primitives.Operations is
null; null;
end Set_Priority; end Set_Priority;
-----------------------
-- Set_Task_Affinity --
-----------------------
procedure Set_Task_Affinity (T : ST.Task_Id) is
begin
null;
end Set_Task_Affinity;
-------------- --------------
-- Set_True -- -- Set_True --
-------------- --------------
......
gcc/ada/s-taprop-hpux-dce.adb
...@@ -1241,4 +1241,16 @@ package body System.Task_Primitives.Operations is ...@@ -1241,4 +1241,16 @@ package body System.Task_Primitives.Operations is
-- this difference is that sigwait doesn't work when some critical -- this difference is that sigwait doesn't work when some critical
-- signals (SIGABRT, SIGPIPE) are masked. -- 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; end System.Task_Primitives.Operations;
gcc/ada/s-taprop-irix.adb
...@@ -1342,4 +1342,16 @@ package body System.Task_Primitives.Operations is ...@@ -1342,4 +1342,16 @@ package body System.Task_Primitives.Operations is
end if; end if;
end Initialize; 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; end System.Task_Primitives.Operations;
gcc/ada/s-taprop-linux.adb
...@@ -879,6 +879,27 @@ package body System.Task_Primitives.Operations is ...@@ -879,6 +879,27 @@ package body System.Task_Primitives.Operations is
CPU_SETSIZE / 8, CPU_SETSIZE / 8,
T.Common.Task_Info.CPU_Affinity'Access); T.Common.Task_Info.CPU_Affinity'Access);
pragma Assert (Result = 0); 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; end if;
-- Since the initial signal mask of a thread is inherited from the -- Since the initial signal mask of a thread is inherited from the
...@@ -1328,24 +1349,78 @@ package body System.Task_Primitives.Operations is ...@@ -1328,24 +1349,78 @@ package body System.Task_Primitives.Operations is
Abort_Handler_Installed := True; Abort_Handler_Installed := True;
end if; 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 Set_Task_Affinity (Environment_Task);
and then Environment_Task.Common.Base_CPU /= end Initialize;
System.Multiprocessors.Not_A_Specific_CPU
then -----------------------
-- 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 declare
CPU_Set : aliased cpu_set_t := (bits => (others => False)); CPU_Set : access cpu_set_t := null;
Result : Interfaces.C.int;
begin begin
CPU_Set.bits (Integer (Environment_Task.Common.Base_CPU)) := True; -- We look at the specific CPU (Base_CPU) first, then at the
Result := -- Task_Info field, and finally at the assigned dispatching
pthread_setaffinity_np -- domain, if any.
(Environment_Task.Common.LL.Thread,
CPU_SETSIZE / 8, if T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
CPU_Set'Access); -- Set the affinity to an unique CPU
pragma Assert (Result = 0);
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;
end if; end if;
end Initialize; end Set_Task_Affinity;
end System.Task_Primitives.Operations; end System.Task_Primitives.Operations;
gcc/ada/s-taprop-mingw.adb
...@@ -954,21 +954,7 @@ package body System.Task_Primitives.Operations is ...@@ -954,21 +954,7 @@ package body System.Task_Primitives.Operations is
-- Step 4: Handle pragma CPU and Task_Info -- Step 4: Handle pragma CPU and Task_Info
if T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then Set_Task_Affinity (T);
-- 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;
-- Step 5: Now, start it for good -- Step 5: Now, start it for good
...@@ -1074,10 +1060,6 @@ package body System.Task_Primitives.Operations is ...@@ -1074,10 +1060,6 @@ package body System.Task_Primitives.Operations is
Discard : BOOL; Discard : BOOL;
pragma Unreferenced (Discard); pragma Unreferenced (Discard);
Result : DWORD;
use type System.Multiprocessors.CPU_Range;
begin begin
Environment_Task_Id := Environment_Task; Environment_Task_Id := Environment_Task;
OS_Primitives.Initialize; OS_Primitives.Initialize;
...@@ -1109,20 +1091,9 @@ package body System.Task_Primitives.Operations is ...@@ -1109,20 +1091,9 @@ package body System.Task_Primitives.Operations is
Enter_Task (Environment_Task); Enter_Task (Environment_Task);
-- pragma CPU for the environment task -- pragma CPU and dispatching domains 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.
Result := Set_Task_Affinity (Environment_Task);
SetThreadIdealProcessor
(Environment_Task.Common.LL.Thread,
ProcessorId (Environment_Task.Common.Base_CPU) - 1);
pragma Assert (Result = 1);
end if;
end Initialize; end Initialize;
--------------------- ---------------------
...@@ -1377,4 +1348,61 @@ package body System.Task_Primitives.Operations is ...@@ -1377,4 +1348,61 @@ package body System.Task_Primitives.Operations is
return False; return False;
end Continue_Task; 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; end System.Task_Primitives.Operations;
gcc/ada/s-taprop-posix.adb
...@@ -1449,4 +1449,16 @@ package body System.Task_Primitives.Operations is ...@@ -1449,4 +1449,16 @@ package body System.Task_Primitives.Operations is
end if; end if;
end Initialize; 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; end System.Task_Primitives.Operations;
gcc/ada/s-taprop-solaris.adb
...@@ -862,68 +862,12 @@ package body System.Task_Primitives.Operations is ...@@ -862,68 +862,12 @@ package body System.Task_Primitives.Operations is
---------------- ----------------
procedure Enter_Task (Self_ID : Task_Id) 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 begin
Self_ID.Common.LL.Thread := thr_self; Self_ID.Common.LL.Thread := thr_self;
Self_ID.Common.LL.LWP := lwp_self; Self_ID.Common.LL.LWP := lwp_self;
-- pragma CPU Set_Task_Affinity (Self_ID);
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;
Specific.Set (Self_ID); Specific.Set (Self_ID);
...@@ -1987,4 +1931,107 @@ package body System.Task_Primitives.Operations is ...@@ -1987,4 +1931,107 @@ package body System.Task_Primitives.Operations is
return False; return False;
end Continue_Task; 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; end System.Task_Primitives.Operations;
gcc/ada/s-taprop-tru64.adb
...@@ -1355,4 +1355,15 @@ package body System.Task_Primitives.Operations is ...@@ -1355,4 +1355,15 @@ package body System.Task_Primitives.Operations is
end if; end if;
end Initialize; 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; end System.Task_Primitives.Operations;
gcc/ada/s-taprop-vms.adb
...@@ -1254,4 +1254,15 @@ package body System.Task_Primitives.Operations is ...@@ -1254,4 +1254,15 @@ package body System.Task_Primitives.Operations is
Enter_Task (Environment_Task); Enter_Task (Environment_Task);
end Initialize; 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; end System.Task_Primitives.Operations;
gcc/ada/s-taprop-vxworks.adb
...@@ -67,8 +67,10 @@ package body System.Task_Primitives.Operations is ...@@ -67,8 +67,10 @@ package body System.Task_Primitives.Operations is
use System.Parameters; use System.Parameters;
use type System.VxWorks.Ext.t_id; use type System.VxWorks.Ext.t_id;
use type Interfaces.C.int; use type Interfaces.C.int;
use type System.OS_Interface.unsigned;
subtype int is System.OS_Interface.int; subtype int is System.OS_Interface.int;
subtype unsigned is System.OS_Interface.unsigned;
Relative : constant := 0; Relative : constant := 0;
...@@ -883,10 +885,6 @@ package body System.Task_Primitives.Operations is ...@@ -883,10 +885,6 @@ package body System.Task_Primitives.Operations is
Succeeded : out Boolean) Succeeded : out Boolean)
is is
Adjusted_Stack_Size : size_t; Adjusted_Stack_Size : size_t;
Result : int := 0;
use System.Task_Info;
use type System.Multiprocessors.CPU_Range;
begin begin
-- Ask for four extra bytes of stack space so that the ATCB pointer can -- 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 ...@@ -952,26 +950,9 @@ package body System.Task_Primitives.Operations is
-- Set processor affinity -- Set processor affinity
if T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then Set_Task_Affinity (T);
-- 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);
elsif T.Common.Task_Info /= Unspecified_Task_Info then if T.Common.LL.Thread <= 0 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
Succeeded := False; Succeeded := False;
else else
Succeeded := True; Succeeded := True;
...@@ -1371,8 +1352,7 @@ package body System.Task_Primitives.Operations is ...@@ -1371,8 +1352,7 @@ package body System.Task_Primitives.Operations is
procedure Initialize (Environment_Task : Task_Id) is procedure Initialize (Environment_Task : Task_Id) is
Result : int; Result : int;
pragma Unreferenced (Result);
use type System.Multiprocessors.CPU_Range;
begin begin
Environment_Task_Id := Environment_Task; Environment_Task_Id := Environment_Task;
...@@ -1413,19 +1393,64 @@ package body System.Task_Primitives.Operations is ...@@ -1413,19 +1393,64 @@ package body System.Task_Primitives.Operations is
-- Set processor affinity -- Set processor affinity
if Environment_Task.Common.Base_CPU /= Set_Task_Affinity (Environment_Task);
System.Multiprocessors.Not_A_Specific_CPU end Initialize;
then
-----------------------
-- 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 -- 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 -- on VxWorks the first CPU is identified by a 0, so we need to
-- adjust. -- adjust.
Result := Result :=
taskCpuAffinitySet taskCpuAffinitySet
(Environment_Task.Common.LL.Thread, (T.Common.LL.Thread, int (T.Common.Base_CPU) - 1);
int (Environment_Task.Common.Base_CPU) - 1);
pragma Assert (Result /= -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 if;
end Initialize; end Set_Task_Affinity;
end System.Task_Primitives.Operations; end System.Task_Primitives.Operations;
gcc/ada/s-taprop.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -543,4 +543,12 @@ package System.Task_Primitives.Operations is ...@@ -543,4 +543,12 @@ package System.Task_Primitives.Operations is
-- such functionality. Such functionality is needed by gdb on some targets -- such functionality. Such functionality is needed by gdb on some targets
-- (e.g VxWorks) Return True is the operation is successful -- (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; end System.Task_Primitives.Operations;
gcc/ada/s-taskin.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -218,6 +218,21 @@ package body System.Tasking is ...@@ -218,6 +218,21 @@ package body System.Tasking is
T.Common.Task_Image_Len := Main_Task_Image'Length; T.Common.Task_Image_Len := Main_Task_Image'Length;
T.Common.Task_Image (Main_Task_Image'Range) := Main_Task_Image; 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 -- Only initialize the first element since others are not relevant
-- in ravenscar mode. Rest of the initialization is done in Init_RTS. -- in ravenscar mode. Rest of the initialization is done in Init_RTS.
......
gcc/ada/s-taskin.ads
...@@ -375,6 +375,29 @@ package System.Tasking is ...@@ -375,6 +375,29 @@ package System.Tasking is
-- terminates. -- 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 -- -- Task related other definitions --
------------------------------------ ------------------------------------
...@@ -637,6 +660,16 @@ package System.Tasking is ...@@ -637,6 +660,16 @@ package System.Tasking is
Debug_Events : Debug_Event_Array; Debug_Events : Debug_Event_Array;
-- Word length array of per task debug events, of which 11 kinds are -- Word length array of per task debug events, of which 11 kinds are
-- currently defined in System.Tasking.Debugging package. -- 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; end record;
--------------------------------------- ---------------------------------------
......
gcc/ada/s-tassta.adb
...@@ -539,6 +539,10 @@ package body System.Tasking.Stages is ...@@ -539,6 +539,10 @@ package body System.Tasking.Stages is
else System.Multiprocessors.CPU_Range (CPU)); else System.Multiprocessors.CPU_Range (CPU));
end if; 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 -- Find parent P of new Task, via master level number
P := Self_ID; P := Self_ID;
...@@ -638,6 +642,17 @@ package body System.Tasking.Stages is ...@@ -638,6 +642,17 @@ package body System.Tasking.Stages is
T.Common.Task_Image_Len := Len; T.Common.Task_Image_Len := Len;
end if; 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 (Self_ID);
Unlock_RTS; Unlock_RTS;
......
gcc/ada/s-vxwext-kernel.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -75,6 +75,16 @@ package body System.VxWorks.Ext is ...@@ -75,6 +75,16 @@ package body System.VxWorks.Ext is
return ERROR; return ERROR;
end taskCpuAffinitySet; 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 -- -- taskStop --
-------------- --------------
......
gcc/ada/s-vxwext-kernel.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -43,6 +43,7 @@ package System.VxWorks.Ext is ...@@ -43,6 +43,7 @@ package System.VxWorks.Ext is
type t_id is new Long_Integer; type t_id is new Long_Integer;
subtype int is Interfaces.C.int; subtype int is Interfaces.C.int;
subtype unsigned is Interfaces.C.unsigned;
type Interrupt_Handler is access procedure (parameter : System.Address); type Interrupt_Handler is access procedure (parameter : System.Address);
pragma Convention (C, Interrupt_Handler); pragma Convention (C, Interrupt_Handler);
...@@ -101,4 +102,9 @@ package System.VxWorks.Ext is ...@@ -101,4 +102,9 @@ package System.VxWorks.Ext is
-- For SMP run-times set the CPU affinity. -- For SMP run-times set the CPU affinity.
-- For uniprocessor systems return ERROR status. -- 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; end System.VxWorks.Ext;
gcc/ada/s-vxwext-rtp.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -121,4 +121,14 @@ package body System.VxWorks.Ext is ...@@ -121,4 +121,14 @@ package body System.VxWorks.Ext is
return ERROR; return ERROR;
end taskCpuAffinitySet; 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; end System.VxWorks.Ext;
gcc/ada/s-vxwext-rtp.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -43,6 +43,7 @@ package System.VxWorks.Ext is ...@@ -43,6 +43,7 @@ package System.VxWorks.Ext is
type t_id is new Long_Integer; type t_id is new Long_Integer;
subtype int is Interfaces.C.int; subtype int is Interfaces.C.int;
subtype unsigned is Interfaces.C.unsigned;
type Interrupt_Handler is access procedure (parameter : System.Address); type Interrupt_Handler is access procedure (parameter : System.Address);
pragma Convention (C, Interrupt_Handler); pragma Convention (C, Interrupt_Handler);
...@@ -95,4 +96,9 @@ package System.VxWorks.Ext is ...@@ -95,4 +96,9 @@ package System.VxWorks.Ext is
-- For SMP run-times set the CPU affinity. -- For SMP run-times set the CPU affinity.
-- For uniprocessor systems return ERROR status. -- 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; end System.VxWorks.Ext;
gcc/ada/s-vxwext.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -42,4 +42,14 @@ package body System.VxWorks.Ext is ...@@ -42,4 +42,14 @@ package body System.VxWorks.Ext is
return ERROR; return ERROR;
end taskCpuAffinitySet; 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; end System.VxWorks.Ext;
gcc/ada/s-vxwext.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -44,6 +44,7 @@ package System.VxWorks.Ext is ...@@ -44,6 +44,7 @@ package System.VxWorks.Ext is
type t_id is new Long_Integer; type t_id is new Long_Integer;
subtype int is Interfaces.C.int; subtype int is Interfaces.C.int;
subtype unsigned is Interfaces.C.unsigned;
type Interrupt_Handler is access procedure (parameter : System.Address); type Interrupt_Handler is access procedure (parameter : System.Address);
pragma Convention (C, Interrupt_Handler); pragma Convention (C, Interrupt_Handler);
...@@ -96,4 +97,9 @@ package System.VxWorks.Ext is ...@@ -96,4 +97,9 @@ package System.VxWorks.Ext is
-- For SMP run-times set the CPU affinity. -- For SMP run-times set the CPU affinity.
-- For uniprocessor systems return ERROR status. -- 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; end System.VxWorks.Ext;
gcc/ada/s-winext.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -53,6 +53,11 @@ package System.Win32.Ext is ...@@ -53,6 +53,11 @@ package System.Win32.Ext is
dwIdealProcessor : ProcessorId) return DWORD; dwIdealProcessor : ProcessorId) return DWORD;
pragma Import (Stdcall, SetThreadIdealProcessor, "SetThreadIdealProcessor"); pragma Import (Stdcall, SetThreadIdealProcessor, "SetThreadIdealProcessor");
function SetThreadAffinityMask
(hThread : HANDLE;
dwThreadAffinityMask : DWORD) return DWORD;
pragma Import (Stdcall, SetThreadAffinityMask, "SetThreadAffinityMask");
-------------- --------------
-- Com Port -- -- Com Port --
-------------- --------------
......
gcc/ada/sem_ch13.adb
...@@ -3904,9 +3904,7 @@ package body Sem_Ch13 is ...@@ -3904,9 +3904,7 @@ package body Sem_Ch13 is
-- This seems dubious, this destroys the source tree in a manner -- This seems dubious, this destroys the source tree in a manner
-- not detectable by ASIS ??? -- not detectable by ASIS ???
if Operating_Mode = Check_Semantics if Operating_Mode = Check_Semantics and then ASIS_Mode then
and then ASIS_Mode
then
AtM_Nod := AtM_Nod :=
Make_Attribute_Definition_Clause (Loc, Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (Base_Type (Rectype), Loc), Name => New_Reference_To (Base_Type (Rectype), Loc),
......
gcc/ada/sem_ch4.adb
...@@ -30,7 +30,6 @@ with Einfo; use Einfo; ...@@ -30,7 +30,6 @@ with Einfo; use Einfo;
with Elists; use Elists; with Elists; use Elists;
with Errout; use Errout; with Errout; use Errout;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Expander; use Expander;
with Fname; use Fname; with Fname; use Fname;
with Itypes; use Itypes; with Itypes; use Itypes;
with Lib; use Lib; with Lib; use Lib;
...@@ -3352,14 +3351,19 @@ package body Sem_Ch4 is ...@@ -3352,14 +3351,19 @@ package body Sem_Ch4 is
Iterator : Node_Id; Iterator : Node_Id;
begin begin
-- Analyze construct with expansion disabled, because it will be Set_Etype (Ent, Standard_Void_Type);
-- rewritten as a loop during expansion. Set_Scope (Ent, Current_Scope);
Set_Parent (Ent, N);
Expander_Mode_Save_And_Set (False);
Check_SPARK_Restriction ("quantified expression is not allowed", N); Check_SPARK_Restriction ("quantified expression is not allowed", N);
Set_Etype (Ent, Standard_Void_Type); -- If expansion is enabled, the condition is analyzed after rewritten
Set_Parent (Ent, N); -- 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 if Present (Loop_Parameter_Specification (N)) then
Iterator := Iterator :=
...@@ -3390,7 +3394,6 @@ package body Sem_Ch4 is ...@@ -3390,7 +3394,6 @@ package body Sem_Ch4 is
Analyze (Condition (N)); Analyze (Condition (N));
End_Scope; End_Scope;
Set_Etype (N, Standard_Boolean); Set_Etype (N, Standard_Boolean);
Expander_Mode_Restore;
end Analyze_Quantified_Expression; end Analyze_Quantified_Expression;
------------------- -------------------
......
gcc/ada/sem_ch5.adb
...@@ -2250,15 +2250,11 @@ package body Sem_Ch5 is ...@@ -2250,15 +2250,11 @@ package body Sem_Ch5 is
Analyze (Subt); Analyze (Subt);
end if; end if;
-- If it is an expression, the name is pre-analyzed in the caller. -- If the domain of iteration is an expression, create a declaration
-- If it it of a controlled type we need a block for the finalization -- for it, so that finalization actions are introduced outside of the
-- actions. As for loop bounds that need finalization, we create a -- loop.
-- declaration and an assignment to trigger these actions.
if not Is_Entity_Name (Iter_Name) then
if Present (Etype (Iter_Name))
and then Is_Controlled (Etype (Iter_Name))
and then not Is_Entity_Name (Iter_Name)
then
declare declare
Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name); Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name);
......
gcc/ada/sem_res.adb
...@@ -8085,6 +8085,13 @@ package body Sem_Res is ...@@ -8085,6 +8085,13 @@ package body Sem_Res is
begin begin
if not ALFA_Mode then 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 loop structure is already resolved during its analysis, only
-- the resolution of the condition needs to be done. Expansion is -- the resolution of the condition needs to be done. Expansion is
-- disabled so that checks and other generated code are inserted in -- disabled so that checks and other generated code are inserted in
......
gcc/ada/vms_conv.adb
...@@ -1799,6 +1799,16 @@ package body VMS_Conv is ...@@ -1799,6 +1799,16 @@ package body VMS_Conv is
(Arg (Arg'First .. SwP), (Arg (Arg'First .. SwP),
Command.Switches, Command.Switches,
Quiet => False); 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; end if;
if Sw /= null then if Sw /= null then
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment