# 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.
s-inmaop$(objext) \
s-interr$(objext) \
s-intman$(objext) \
+ s-mudido$(objext) \
s-oscons$(objext) \
s-osinte$(objext) \
s-proinf$(objext) \
--- /dev/null
+/****************************************************************************
+ * *
+ * 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);
+}
-- 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
-- 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
-- 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;
------------------
& 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;");
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
-- Generate output file in appropriate language
Check_System_Restrictions_Used;
+ Check_Dispatching_Domains_Used;
Gen_Output_File_Ada (Filename);
end Gen_Output_File;
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),
-- 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);
-- 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
Container_Arg := New_Copy_Tree (Container);
else
- Pack := Scope (Default_Iter);
-
Container_Arg :=
Make_Type_Conversion (Loc,
Subtype_Mark =>
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
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,
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
-- 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 --
-------------------------
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);
Error_Msg
("expect identifier in parameter association",
Sloc (Expr_Node));
- Scan; -- past arrow
+ Scan; -- past arrow
elsif not Comma_Present then
T_Right_Paren;
-- 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;
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;
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;
-- 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
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
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
-- 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- --
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
-- 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- --
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;
-- 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 --
---------------------
-- --
-- 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- --
null;
end Set_Priority;
+ -----------------------
+ -- Set_Task_Affinity --
+ -----------------------
+
+ procedure Set_Task_Affinity (T : ST.Task_Id) is
+ begin
+ null;
+ end Set_Task_Affinity;
+
--------------
-- Set_True --
--------------
-- 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;
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;
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
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;
-- 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
Discard : BOOL;
pragma Unreferenced (Discard);
- Result : DWORD;
-
- use type System.Multiprocessors.CPU_Range;
-
begin
Environment_Task_Id := Environment_Task;
OS_Primitives.Initialize;
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;
---------------------
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;
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;
----------------
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);
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;
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;
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;
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;
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
-- 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;
procedure Initialize (Environment_Task : Task_Id) is
Result : int;
-
- use type System.Multiprocessors.CPU_Range;
+ pragma Unreferenced (Result);
begin
Environment_Task_Id := Environment_Task;
-- 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;
-- --
-- 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- --
-- 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;
-- --
-- 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- --
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.
-- Used to represent protected procedures to be executed when task
-- 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 --
------------------------------------
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;
---------------------------------------
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;
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;
-- --
-- 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- --
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 --
--------------
-- --
-- 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- --
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);
-- 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;
-- --
-- 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- --
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;
-- --
-- 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- --
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);
-- 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;
-- --
-- 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- --
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;
-- --
-- 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- --
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);
-- 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;
-- --
-- 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- --
dwIdealProcessor : ProcessorId) return DWORD;
pragma Import (Stdcall, SetThreadIdealProcessor, "SetThreadIdealProcessor");
+ function SetThreadAffinityMask
+ (hThread : HANDLE;
+ dwThreadAffinityMask : DWORD) return DWORD;
+ pragma Import (Stdcall, SetThreadAffinityMask, "SetThreadAffinityMask");
+
--------------
-- Com Port --
--------------
-- 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),
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;
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 :=
Analyze (Condition (N));
End_Scope;
Set_Etype (N, Standard_Boolean);
- Expander_Mode_Restore;
end Analyze_Quantified_Expression;
-------------------
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);
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
(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
projects / thirdparty / gcc.git / commitdiff
