[Ada] Non-preemptive dispatching
Arnaud Charlet
charlet@adacore.com
Fri Feb 20 11:49:00 GMT 2015
Make Non_Preemptive_FIFO_Within_Priorities a standard dispatching policy
name as defined in RM D.2.4(2/2).
Create the language-defined library package Ada.Dispatching.Non_Preemptive,
as defined in RM D.2.4(2.2/3). This package is marked as unimplemented
because no target environment supports it.
Add the procedure Ada.Dispatching.Yield, introduced by Ada 2012 in
RM D.2.1(1.3/3).
The following test should trigger an error in the use of package
Ada.Dispatching.Non_Preemptive (not implemented) as shown:
pragma Task_Dispatching_Policy (Non_Preemptive_FIFO_Within_Priorities);
with Ada.Dispatching.Non_Preemptive;
procedure Non_Preemptive is
begin
null;
end Non_Preemptive;
$ gcc -c non_preemptive.adb
Non_Preemptive is not supported in this configuration
compilation abandoned
Tested on x86_64-pc-linux-gnu, committed on trunk
2015-02-20 Jose Ruiz <ruiz@adacore.com>
* a-dinopr.ads: Add spec for this package (Unimplemented_Unit).
* a-dispat.ads (Yield): Include procedure added in Ada 2012.
* a-dispat.adb (Yield): Implement procedure added in Ada 2012.
* impunit.adb (Non_Imp_File_Names_05): Mark unit a-dinopr.ads as
defined by Ada 2005.
* snames.ads-tmpl (Name_Non_Preemptive_FIFO_Within_Priorities):
This is the correct name for the dispatching policy (FIFO was
missing).
-------------- next part --------------
Index: impunit.adb
===================================================================
--- impunit.adb (revision 220835)
+++ impunit.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2015, 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- --
@@ -427,6 +427,7 @@
("a-coorse", T), -- Ada.Containers.Ordered_Sets
("a-coteio", T), -- Ada.Complex_Text_IO
("a-direct", T), -- Ada.Directories
+ ("a-dinopr", T), -- Ada.Dispatching.Non_Preemptive
("a-diroro", T), -- Ada.Dispatching.Round_Robin
("a-disedf", T), -- Ada.Dispatching.EDF
("a-dispat", T), -- Ada.Dispatching
Index: a-dispat.adb
===================================================================
--- a-dispat.adb (revision 0)
+++ a-dispat.adb (revision 0)
@@ -0,0 +1,57 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . D I S P A T C H I N G --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2015, 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 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/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions;
+with System.Tasking;
+with System.Task_Primitives.Operations;
+
+package body Ada.Dispatching is
+
+ procedure Yield is
+ Self_Id : constant System.Tasking.Task_Id :=
+ System.Task_Primitives.Operations.Self;
+
+ begin
+ -- If pragma Detect_Blocking is active, Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action.
+
+ if System.Tasking.Detect_Blocking
+ and then Self_Id.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ else
+ System.Task_Primitives.Operations.Yield;
+ end if;
+ end Yield;
+
+end Ada.Dispatching;
Index: a-dispat.ads
===================================================================
--- a-dispat.ads (revision 220835)
+++ a-dispat.ads (working copy)
@@ -14,7 +14,9 @@
------------------------------------------------------------------------------
package Ada.Dispatching is
- pragma Pure (Dispatching);
+ pragma Preelaborate (Dispatching);
+ procedure Yield;
+
Dispatching_Policy_Error : exception;
end Ada.Dispatching;
Index: a-dinopr.ads
===================================================================
--- a-dinopr.ads (revision 0)
+++ a-dinopr.ads (revision 0)
@@ -0,0 +1,31 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . D I S P A T C H I N G . N O N _ P R E E M P T I V E --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This unit is not implemented in typical GNAT implementations that lie on
+-- top of operating systems, because it is infeasible to implement in such
+-- environments.
+
+-- If a target environment provides appropriate support for this package,
+-- then the Unimplemented_Unit pragma should be removed from this spec and
+-- an appropriate body provided.
+
+package Ada.Dispatching.Non_Preemptive is
+ pragma Preelaborate (Non_Preemptive);
+
+ pragma Unimplemented_Unit;
+
+ procedure Yield_To_Higher;
+ procedure Yield_To_Same_Or_Higher renames Yield;
+end Ada.Dispatching.Non_Preemptive;
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl (revision 220835)
+++ snames.ads-tmpl (working copy)
@@ -1063,12 +1063,12 @@
-- for FIFO_Within_Priorities). If new policy names are added, the first
-- character must be distinct.
- First_Task_Dispatching_Policy_Name : constant Name_Id := N + $;
- Name_EDF_Across_Priorities : constant Name_Id := N + $;
- Name_FIFO_Within_Priorities : constant Name_Id := N + $;
- Name_Non_Preemptive_Within_Priorities : constant Name_Id := N + $;
- Name_Round_Robin_Within_Priorities : constant Name_Id := N + $;
- Last_Task_Dispatching_Policy_Name : constant Name_Id := N + $;
+ First_Task_Dispatching_Policy_Name : constant Name_Id := N + $;
+ Name_EDF_Across_Priorities : constant Name_Id := N + $;
+ Name_FIFO_Within_Priorities : constant Name_Id := N + $;
+ Name_Non_Preemptive_FIFO_Within_Priorities : constant Name_Id := N + $;
+ Name_Round_Robin_Within_Priorities : constant Name_Id := N + $;
+ Last_Task_Dispatching_Policy_Name : constant Name_Id := N + $;
-- Names of recognized partition elaboration policy identifiers
More information about the Gcc-patches
mailing list