OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2005-03-08  Robert Dewar  <dewar@adacore.com>

	* s-bitops.adb, s-bitops.ads,
	s-taprop-os2.adb, s-intman-vms.ads, s-intman-vxworks.ads,
	s-taprop-vxworks.adb, a-caldel.ads, a-calend.adb, a-tasatt.adb,
	tbuild.ads, s-finimp.adb, s-imgwch.adb, s-intman.ads, s-intman.ads,
	s-memory.adb, s-soflin.ads, s-taasde.ads, s-taprob.adb, s-taprop.ads,
	s-taprop.ads, s-tasini.adb, s-tasini.ads, s-tasini.ads, s-tasini.ads,
	s-taskin.ads, s-tasren.adb, s-tassta.adb, s-tassta.ads, s-tassta.ads,
	s-tasuti.ads, s-tataat.ads, s-tataat.ads, s-tataat.ads, s-tataat.ads,
	s-tpoben.adb, s-tpoben.adb, s-tpobop.ads: Update comments. Minor
	reformatting.

2005-03-08  Eric Botcazou  <ebotcazou@adacore.com>

	* utils2.c (build_binary_op): Fix typo.

2005-03-08  Doug Rupp  <rupp@adacore.com>

	* s-crtl.ads (popen,pclose): New imports.

2005-03-08  Cyrille Comar  <comar@adacore.com>

	* comperr.adb (Compiler_Abort): remove references to obsolete
	procedures in the bug boxes for various GNAT builds.

2005-03-08  Vincent Celier  <celier@adacore.com>

	* snames.ads, snames.adb: Save as Unix text file, not as DOS text file

From-SVN: r96512
This commit is contained in:
Arnaud Charlet 2005-03-15 17:19:40 +01:00
parent 728c3084ee
commit 1a49cf99b7
32 changed files with 3640 additions and 3650 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
gcc/ada/a-caldel.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-1998, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -39,18 +39,17 @@
package Ada.Calendar.Delays is
procedure Delay_For (D : Duration);
-- Delay until an interval of length (at least) D seconds has passed,
-- or the task is aborted to at least the current ATC nesting level.
-- This is an abort completion point.
-- The body of this procedure must perform all the processing
-- required for an abortion point.
-- Delay until an interval of length (at least) D seconds has passed, or
-- the task is aborted to at least the current ATC nesting level. This is
-- an abort completion point. The body of this procedure must perform all
-- the processing required for an abort point.
procedure Delay_Until (T : Time);
-- Delay until Clock has reached (at least) time T,
-- or the task is aborted to at least the current ATC nesting level.
-- The body of this procedure must perform all the processing
-- required for an abortion point.
-- Delay until Clock has reached (at least) time T, or the task is aborted
-- to at least the current ATC nesting level. The body of this procedure
-- must perform all the processing required for an abort point.
function To_Duration (T : Time) return Duration;
-- Convert Time to Duration
end Ada.Calendar.Delays;

86
gcc/ada/a-calend.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 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- --
@ -91,15 +91,16 @@ package body Ada.Calendar is
-- The following constants are used in adjusting Ada dates so that they
-- fit into a 56 year range that can be handled by Unix (1970 included -
-- 2026 excluded). Dates that are not in this 56 year range are shifted
-- by multiples of 56 years to fit in this range
-- by multiples of 56 years to fit in this range.
-- The trick is that the number of days in any four year period in the Ada
-- range of years (1901 - 2099) has a constant number of days. This is
-- because we have the special case of 2000 which, contrary to the normal
-- exception for centuries, is a leap year after all.
-- 56 has been chosen, because it is not only a multiple of 4, but also
-- a multiple of 7. Thus two dates 56 years apart fall on the same day of
-- the week, and the Daylight Saving Time change dates are usually the same
-- for these two years.
-- exception for centuries, is a leap year after all. 56 has been chosen,
-- because it is not only a multiple of 4, but also a multiple of 7. Thus
-- two dates 56 years apart fall on the same day of the week, and the
-- Daylight Saving Time change dates are usually the same for these two
-- years.
Unix_Year_Min : constant := 1970;
Unix_Year_Max : constant := 2026;
@ -125,7 +126,6 @@ package body Ada.Calendar is
pragma Unsuppress (Overflow_Check);
begin
return (Left + Time (Right));
exception
when Constraint_Error =>
raise Time_Error;
@ -135,7 +135,6 @@ package body Ada.Calendar is
pragma Unsuppress (Overflow_Check);
begin
return (Time (Left) + Right);
exception
when Constraint_Error =>
raise Time_Error;
@ -149,7 +148,6 @@ package body Ada.Calendar is
pragma Unsuppress (Overflow_Check);
begin
return Left - Time (Right);
exception
when Constraint_Error =>
raise Time_Error;
@ -159,7 +157,6 @@ package body Ada.Calendar is
pragma Unsuppress (Overflow_Check);
begin
return Duration (Left) - Duration (Right);
exception
when Constraint_Error =>
raise Time_Error;
@ -219,7 +216,6 @@ package body Ada.Calendar is
DM : Month_Number;
DD : Day_Number;
DS : Day_Duration;
begin
Split (Date, DY, DM, DD, DS);
return DD;
@ -234,7 +230,6 @@ package body Ada.Calendar is
DM : Month_Number;
DD : Day_Number;
DS : Day_Duration;
begin
Split (Date, DY, DM, DD, DS);
return DM;
@ -249,7 +244,6 @@ package body Ada.Calendar is
DM : Month_Number;
DD : Day_Number;
DS : Day_Duration;
begin
Split (Date, DY, DM, DD, DS);
return DS;
@ -291,11 +285,11 @@ package body Ada.Calendar is
D := Duration (Date);
-- First of all, filter out completely ludicrous values. Remember
-- that we use the full stored range of duration values, which may
-- be significantly larger than the allowed range of Ada times. Note
-- that these checks are wider than required to make absolutely sure
-- that there are no end effects from time zone differences.
-- First of all, filter out completely ludicrous values. Remember that
-- we use the full stored range of duration values, which may be
-- significantly larger than the allowed range of Ada times. Note that
-- these checks are wider than required to make absolutely sure that
-- there are no end effects from time zone differences.
if D < LowD or else D > HighD then
raise Time_Error;
@ -306,11 +300,11 @@ package body Ada.Calendar is
-- required range of years (the guaranteed range available is only
-- EPOCH through EPOCH + N seconds). N is in practice 2 ** 31 - 1.
-- If we have a value outside this range, then we first adjust it
-- to be in the required range by adding multiples of 56 years.
-- For the range we are interested in, the number of days in any
-- consecutive 56 year period is constant. Then we do the split
-- on the adjusted value, and readjust the years value accordingly.
-- If we have a value outside this range, then we first adjust it to be
-- in the required range by adding multiples of 56 years. For the range
-- we are interested in, the number of days in any consecutive 56 year
-- period is constant. Then we do the split on the adjusted value, and
-- readjust the years value accordingly.
Year_Val := 0;
@ -325,13 +319,13 @@ package body Ada.Calendar is
end loop;
-- Now we need to take the value D, which is now non-negative, and
-- break it down into seconds (to pass to the localtime_r function)
-- and fractions of seconds (for the adjustment below).
-- break it down into seconds (to pass to the localtime_r function) and
-- fractions of seconds (for the adjustment below).
-- Surprisingly there is no easy way to do this in Ada, and certainly
-- no easy way to do it and generate efficient code. Therefore we
-- do it at a low level, knowing that it is really represented as
-- an integer with units of Small
-- no easy way to do it and generate efficient code. Therefore we do it
-- at a low level, knowing that it is really represented as an integer
-- with units of Small
declare
type D_Int is range 0 .. 2 ** (Duration'Size - 1) - 1;
@ -356,18 +350,18 @@ package body Ada.Calendar is
Day := Tm_Val.tm_mday;
-- The Seconds value is a little complex. The localtime function
-- returns the integral number of seconds, which is what we want,
-- but we want to retain the fractional part from the original
-- Time value, since this is typically stored more accurately.
-- returns the integral number of seconds, which is what we want, but
-- we want to retain the fractional part from the original Time value,
-- since this is typically stored more accurately.
Seconds := Duration (Tm_Val.tm_hour * 3600 +
Tm_Val.tm_min * 60 +
Tm_Val.tm_sec)
+ Frac_Sec;
-- Note: the above expression is pretty horrible, one of these days
-- we should stop using time_of and do everything ourselves to avoid
-- these unnecessary divides and multiplies???.
-- Note: the above expression is pretty horrible, one of these days we
-- should stop using time_of and do everything ourselves to avoid these
-- unnecessary divides and multiplies???.
-- The Year may still be out of range, since our entry test was
-- deliberately crude. Trying to make this entry test accurate is
@ -404,8 +398,8 @@ package body Ada.Calendar is
begin
-- The following checks are redundant with respect to the constraint
-- error checks that should normally be made on parameters, but we
-- decide to raise Constraint_Error in any case if bad values come
-- in (as a result of checks being off in the caller, or for other
-- decide to raise Constraint_Error in any case if bad values come in
-- (as a result of checks being off in the caller, or for other
-- erroneous or bounded error cases).
if not Year 'Valid
@ -433,10 +427,10 @@ package body Ada.Calendar is
TM_Val.tm_mon := Month - 1;
-- For the year, we have to adjust it to a year that Unix can handle.
-- We do this in 56 year steps, since the number of days in 56 years
-- is constant, so the timezone effect on the conversion from local
-- time to GMT is unaffected; also the DST change dates are usually
-- not modified.
-- We do this in 56 year steps, since the number of days in 56 years is
-- constant, so the timezone effect on the conversion from local time
-- to GMT is unaffected; also the DST change dates are usually not
-- modified.
while Year_Val < Unix_Year_Min loop
Year_Val := Year_Val + 56;
@ -450,8 +444,8 @@ package body Ada.Calendar is
TM_Val.tm_year := Year_Val - 1900;
-- Since we do not have information on daylight savings,
-- rely on the default information.
-- Since we do not have information on daylight savings, rely on the
-- default information.
TM_Val.tm_isdst := -1;
Result_Secs := mktime (TM_Val'Unchecked_Access);
@ -459,14 +453,13 @@ package body Ada.Calendar is
-- That gives us the basic value in seconds. Two adjustments are
-- needed. First we must undo the year adjustment carried out above.
-- Second we put back the fraction seconds value since in general the
-- Day_Duration value we received has additional precision which we
-- do not want to lose in the constructed result.
-- Day_Duration value we received has additional precision which we do
-- not want to lose in the constructed result.
return
Time (Duration (Result_Secs) +
Duration_Adjust +
(Seconds - Duration (Int_Secs)));
end Time_Of;
----------
@ -478,7 +471,6 @@ package body Ada.Calendar is
DM : Month_Number;
DD : Day_Number;
DS : Day_Duration;
begin
Split (Date, DY, DM, DD, DS);
return DY;

347
gcc/ada/a-tasatt.adb
View File

@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2004, Ada Core Technologies --
-- Copyright (C) 1995-2005, Ada Core Technologies --
-- --
-- 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- --
@ -32,174 +32,171 @@
-- --
------------------------------------------------------------------------------
-- The following notes are provided in case someone decides the
-- implementation of this package is too complicated, or too slow.
-- Please read this before making any "simplifications".
-- The following notes are provided in case someone decides the implementation
-- of this package is too complicated, or too slow. Please read this before
-- making any "simplifications".
-- Correct implementation of this package is more difficult than one
-- might expect. After considering (and coding) several alternatives,
-- we settled on the present compromise. Things we do not like about
-- this implementation include:
-- Correct implementation of this package is more difficult than one might
-- expect. After considering (and coding) several alternatives, we settled on
-- the present compromise. Things we do not like about this implementation
-- include:
-- - It is vulnerable to bad Task_Id values, to the extent of
-- possibly trashing memory and crashing the runtime system.
-- - It is vulnerable to bad Task_Id values, to the extent of possibly
-- trashing memory and crashing the runtime system.
-- - It requires dynamic storage allocation for each new attribute value,
-- except for types that happen to be the same size as System.Address,
-- or shorter.
-- except for types that happen to be the same size as System.Address, or
-- shorter.
-- - Instantiations at other than the library level rely on being able to
-- do down-level calls to a procedure declared in the generic package body.
-- This makes it potentially vulnerable to compiler changes.
-- The main implementation issue here is that the connection from
-- task to attribute is a potential source of dangling references.
-- The main implementation issue here is that the connection from task to
-- attribute is a potential source of dangling references.
-- When a task goes away, we want to be able to recover all the storage
-- associated with its attributes. The Ada mechanism for this is
-- finalization, via controlled attribute types. For this reason,
-- the ARM requires finalization of attribute values when the
-- associated task terminates.
-- finalization, via controlled attribute types. For this reason, the ARM
-- requires finalization of attribute values when the associated task
-- terminates.
-- This finalization must be triggered by the tasking runtime system,
-- during termination of the task. Given the active set of instantiations
-- of Ada.Task_Attributes is dynamic, the number and types of attributes
-- This finalization must be triggered by the tasking runtime system, during
-- termination of the task. Given the active set of instantiations of
-- Ada.Task_Attributes is dynamic, the number and types of attributes
-- belonging to a task will not be known until the task actually terminates.
-- Some of these types may be controlled and some may not. The RTS must find
-- some way to determine which of these attributes need finalization, and
-- invoke the appropriate finalization on them.
-- One way this might be done is to create a special finalization chain
-- for each task, similar to the finalization chain that is used for
-- controlled objects within the task. This would differ from the usual
-- finalization chain in that it would not have a LIFO structure, since
-- attributes may be added to a task at any time during its lifetime.
-- This might be the right way to go for the longer term, but at present
-- this approach is not open, since GNAT does not provide such special
-- finalization support.
-- One way this might be done is to create a special finalization chain for
-- each task, similar to the finalization chain that is used for controlled
-- objects within the task. This would differ from the usual finalization
-- chain in that it would not have a LIFO structure, since attributes may be
-- added to a task at any time during its lifetime. This might be the right
-- way to go for the longer term, but at present this approach is not open,
-- since GNAT does not provide such special finalization support.
-- Lacking special compiler support, the RTS is limited to the
-- normal ways an application invokes finalization, i.e.
-- Lacking special compiler support, the RTS is limited to the normal ways an
-- application invokes finalization, i.e.
-- a) Explicit call to the procedure Finalize, if we know the type
-- has this operation defined on it. This is not sufficient, since
-- we have no way of determining whether a given generic formal
-- Attribute type is controlled, and no visibility of the associated
-- Finalize procedure, in the generic body.
-- a) Explicit call to the procedure Finalize, if we know the type has this
-- operation defined on it. This is not sufficient, since we have no way
-- of determining whether a given generic formal Attribute type is
-- controlled, and no visibility of the associated Finalize procedure, in
-- the generic body.
-- b) Leaving the scope of a local object of a controlled type.
-- This does not help, since the lifetime of an instantiation of
-- Ada.Task_Attributes does not correspond to the lifetimes of the
-- various tasks which may have that attribute.
-- b) Leaving the scope of a local object of a controlled type. This does not
-- help, since the lifetime of an instantiation of Ada.Task_Attributes
-- does not correspond to the lifetimes of the various tasks which may
-- have that attribute.
-- c) Assignment of another value to the object. This would not help,
-- since we then have to finalize the new value of the object.
-- c) Assignment of another value to the object. This would not help, since
-- we then have to finalize the new value of the object.
-- d) Unchecked deallocation of an object of a controlled type.
-- This seems to be the only mechanism available to the runtime
-- system for finalization of task attributes.
-- d) Unchecked deallocation of an object of a controlled type. This seems to
-- be the only mechanism available to the runtime system for finalization
-- of task attributes.
-- We considered two ways of using unchecked deallocation, both based
-- on a linked list of that would hang from the task control block.
-- We considered two ways of using unchecked deallocation, both based on a
-- linked list of that would hang from the task control block.
-- In the first approach the objects on the attribute list are all derived
-- from one controlled type, say T, and are linked using an access type to
-- T'Class. The runtime system has an Unchecked_Deallocation for T'Class
-- with access type T'Class, and uses this to deallocate and finalize all
-- the items in the list. The limitation of this approach is that each
-- T'Class. The runtime system has an Unchecked_Deallocation for T'Class with
-- access type T'Class, and uses this to deallocate and finalize all the
-- items in the list. The limitation of this approach is that each
-- instantiation of the package Ada.Task_Attributes derives a new record
-- extension of T, and since T is controlled (RM 3.9.1 (3)), instantiation
-- is only allowed at the library level.
-- extension of T, and since T is controlled (RM 3.9.1 (3)), instantiation is
-- only allowed at the library level.
-- In the second approach the objects on the attribute list are of
-- unrelated but structurally similar types. Unchecked conversion is
-- used to circument Ada type checking. Each attribute-storage node
-- contains not only the attribute value and a link for chaining, but
-- also a pointer to a descriptor for the corresponding instantiation
-- of Task_Attributes. The instantiation-descriptor contains a
-- pointer to a procedure that can do the correct deallocation and
-- finalization for that type of attribute. On task termination, the
-- runtime system uses the pointer to call the appropriate deallocator.
-- In the second approach the objects on the attribute list are of unrelated
-- but structurally similar types. Unchecked conversion is used to circument
-- Ada type checking. Each attribute-storage node contains not only the
-- attribute value and a link for chaining, but also a pointer to descriptor
-- for the corresponding instantiation of Task_Attributes. The instantiation
-- descriptor contains pointer to a procedure that can do the correct
-- deallocation and finalization for that type of attribute. On task
-- termination, the runtime system uses the pointer to call the appropriate
-- deallocator.
-- While this gets around the limitation that instantations be at
-- the library level, it relies on an implementation feature that
-- may not always be safe, i.e. that it is safe to call the
-- Deallocate procedure for an instantiation of Ada.Task_Attributes
-- that no longer exists. In general, it seems this might result in
-- dangling references.
-- While this gets around the limitation that instantations be at the library
-- level, it relies on an implementation feature that may not always be safe,
-- i.e. that it is safe to call the Deallocate procedure for an instantiation
-- of Ada.Task_Attributes that no longer exists. In general, it seems this
-- might result in dangling references.
-- Another problem with instantiations deeper than the library level
-- is that there is risk of storage leakage, or dangling references
-- to reused storage. That is, if an instantiation of Ada.Task_Attributes
-- is made within a procedure, what happens to the storage allocated for
-- attributes, when the procedure call returns? Apparently (RM 7.6.1 (4))
-- any such objects must be finalized, since they will no longer be
-- accessible, and in general one would expect that the storage they occupy
-- would be recovered for later reuse. (If not, we would have a case of
-- storage leakage.) Assuming the storage is recovered and later reused,
-- we have potentially dangerous dangling references. When the procedure
-- containing the instantiation of Ada.Task_Attributes returns, there
-- may still be unterminated tasks with associated attribute values for
-- that instantiation. When such tasks eventually terminate, the RTS
-- will attempt to call the Deallocate procedure on them. If the
-- corresponding storage has already been deallocated, when the master
-- of the access type was left, we have a potential disaster. This
-- disaster is compounded since the pointer to Deallocate is probably
-- through a "trampoline" which will also have been destroyed.
-- Another problem with instantiations deeper than the library level is that
-- there is risk of storage leakage, or dangling references to reused
-- storage. That is, if an instantiation of Ada.Task_Attributes is made
-- within a procedure, what happens to the storage allocated for attributes,
-- when the procedure call returns? Apparently (RM 7.6.1 (4)) any such
-- objects must be finalized, since they will no longer be accessible, and in
-- general one would expect that the storage they occupy would be recovered
-- for later reuse. (If not, we would have a case of storage leakage.)
-- Assuming the storage is recovered and later reused, we have potentially
-- dangerous dangling references. When the procedure containing the
-- instantiation of Ada.Task_Attributes returns, there may still be
-- unterminated tasks with associated attribute values for that instantiation.
-- When such tasks eventually terminate, the RTS will attempt to call the
-- Deallocate procedure on them. If the corresponding storage has already
-- been deallocated, when the master of the access type was left, we have a
-- potential disaster. This disaster is compounded since the pointer to
-- Deallocate is probably through a "trampoline" which will also have been
-- destroyed.
-- For this reason, we arrange to remove all dangling references
-- before leaving the scope of an instantiation. This is ugly, since
-- it requires traversing the list of all tasks, but it is no more ugly
-- than a similar traversal that we must do at the point of instantiation
-- in order to initialize the attributes of all tasks. At least we only
-- need to do these traversals if the type is controlled.
-- For this reason, we arrange to remove all dangling references before
-- leaving the scope of an instantiation. This is ugly, since it requires
-- traversing the list of all tasks, but it is no more ugly than a similar
-- traversal that we must do at the point of instantiation in order to
-- initialize the attributes of all tasks. At least we only need to do these
-- traversals if the type is controlled.
-- We chose to defer allocation of storage for attributes until the
-- Reference function is called or the attribute is first set to a value
-- different from the default initial one. This allows a potential
-- savings in allocation, for attributes that are not used by all tasks.
-- We chose to defer allocation of storage for attributes until the Reference
-- function is called or the attribute is first set to a value different from
-- the default initial one. This allows a potential savings in allocation,
-- for attributes that are not used by all tasks.
-- For efficiency, we reserve space in the TCB for a fixed number of
-- direct-access attributes. These are required to be of a size that
-- fits in the space of an object of type System.Address. Because
-- we must use unchecked bitwise copy operations on these values, they
-- cannot be of a controlled type, but that is covered automatically
-- since controlled objects are too large to fit in the spaces.
-- direct-access attributes. These are required to be of a size that fits in
-- the space of an object of type System.Address. Because we must use
-- unchecked bitwise copy operations on these values, they cannot be of a
-- controlled type, but that is covered automatically since controlled
-- objects are too large to fit in the spaces.
-- We originally deferred the initialization of these direct-access
-- attributes, just as we do for the indirect-access attributes, and
-- used a per-task bit vector to keep track of which attributes were
-- currently defined for that task. We found that the overhead of
-- maintaining this bit-vector seriously slowed down access to the
-- attributes, and made the fetch operation non-atomic, so that even
-- to read an attribute value required locking the TCB. Therefore,
-- we now initialize such attributes for all existing tasks at the time
-- of the attribute instantiation, and initialize existing attributes
-- for each new task at the time it is created.
-- attributes, just as we do for the indirect-access attributes, and used a
-- per-task bit vector to keep track of which attributes were currently
-- defined for that task. We found that the overhead of maintaining this
-- bit-vector seriously slowed down access to the attributes, and made the
-- fetch operation non-atomic, so that even to read an attribute value
-- required locking the TCB. Therefore, we now initialize such attributes for
-- all existing tasks at the time of the attribute instantiation, and
-- initialize existing attributes for each new task at the time it is
-- created.
-- The latter initialization requires a list of all the instantiation
-- descriptors. Updates to this list, as well as the bit-vector that
-- is used to reserve slots for attributes in the TCB, require mutual
-- exclusion. That is provided by the Lock/Unlock_RTS.
-- descriptors. Updates to this list, as well as the bit-vector that is used
-- to reserve slots for attributes in the TCB, require mutual exclusion. That
-- is provided by the Lock/Unlock_RTS.
-- One special problem that added complexity to the design is that
-- the per-task list of indirect attributes contains objects of
-- different types. We use unchecked pointer conversion to link
-- these nodes together and access them, but the records may not have
-- identical internal structure. Initially, we thought it would be
-- enough to allocate all the common components of the records at the
-- front of each record, so that their positions would correspond.
-- Unfortunately, GNAT adds "dope" information at the front of a record,
-- if the record contains any controlled-type components.
-- One special problem that added complexity to the design is that the
-- per-task list of indirect attributes contains objects of different types.
-- We use unchecked pointer conversion to link these nodes together and
-- access them, but the records may not have identical internal structure.
-- Initially, we thought it would be enough to allocate all the common
-- components of the records at the front of each record, so that their
-- positions would correspond. Unfortunately, GNAT adds "dope" information at
-- the front of a record, if the record contains any controlled-type
-- components.
--
-- This means that the offset of the fields we use to link the nodes is
-- at different positions on nodes of different types. To get around this,
-- each attribute storage record consists of a core node and wrapper.
-- The core nodes are all of the same type, and it is these that are
-- linked together and generally "seen" by the RTS. Each core node
-- contains a pointer to its own wrapper, which is a record that contains
-- the core node along with an attribute value, approximately
-- as follows:
-- This means that the offset of the fields we use to link the nodes is at
-- different positions on nodes of different types. To get around this, each
-- attribute storage record consists of a core node and wrapper. The core
-- nodes are all of the same type, and it is these that are linked together
-- and generally "seen" by the RTS. Each core node contains a pointer to its
-- own wrapper, which is a record that contains the core node along with an
-- attribute value, approximately as follows:
-- type Node;
-- type Node_Access is access all Node;
@ -211,51 +208,50 @@
-- Wrapper : Access_Wrapper;
-- end record;
-- type Wrapper is record
-- Noed : aliased Node;
-- Dummy_Node : aliased Node;
-- Value : aliased Attribute; -- the generic formal type
-- end record;
-- Another interesting problem is with the initialization of
-- the instantiation descriptors. Originally, we did this all via
-- the Initialize procedure of the descriptor type and code in the
-- package body. It turned out that the Initialize procedure needed
-- quite a bit of information, including the size of the attribute
-- type, the initial value of the attribute (if it fits in the TCB),
-- and a pointer to the deallocator procedure. These needed to be
-- "passed" in via access discriminants. GNAT was having trouble
-- with access discriminants, so all this work was moved to the
-- package body.
-- Another interesting problem is with the initialization of the
-- instantiation descriptors. Originally, we did this all via the Initialize
-- procedure of the descriptor type and code in the package body. It turned
-- out that the Initialize procedure needed quite a bit of information,
-- including the size of the attribute type, the initial value of the
-- attribute (if it fits in the TCB), and a pointer to the deallocator
-- procedure. These needed to be "passed" in via access discriminants. GNAT
-- was having trouble with access discriminants, so all this work was moved
-- to the package body.
with Ada.Task_Identification;
-- used for Task_Id
-- Used for Task_Id
-- Null_Task_Id
-- Current_Task
with System.Error_Reporting;
-- used for Shutdown;
-- Used for Shutdown;
with System.Storage_Elements;
-- used for Integer_Address
-- Used for Integer_Address
with System.Task_Primitives.Operations;
-- used for Write_Lock
-- Used for Write_Lock
-- Unlock
-- Lock/Unlock_RTS
with System.Tasking;
-- used for Access_Address
-- Used for Access_Address
-- Task_Id
-- Direct_Index_Vector
-- Direct_Index
with System.Tasking.Initialization;
-- used for Defer_Abortion
-- Used for Defer_Abortion
-- Undefer_Abortion
-- Initialize_Attributes_Link
-- Finalize_Attributes_Link
with System.Tasking.Task_Attributes;
-- used for Access_Node
-- Used for Access_Node
-- Access_Dummy_Wrapper
-- Deallocator
-- Instance
@ -263,13 +259,13 @@ with System.Tasking.Task_Attributes;
-- Access_Instance
with Ada.Exceptions;
-- used for Raise_Exception
-- Used for Raise_Exception
with Unchecked_Conversion;
with Unchecked_Deallocation;
pragma Elaborate_All (System.Tasking.Task_Attributes);
-- to ensure the initialization of object Local (below) will work
-- To ensure the initialization of object Local (below) will work
package body Ada.Task_Attributes is
@ -295,11 +291,10 @@ package body Ada.Task_Attributes is
pragma Warnings (Off);
-- We turn warnings off for the following declarations of the
-- To_Attribute_Handle conversions, since these are used only
-- for small attributes where we know that there are no problems
-- with alignment, but the compiler will generate warnings for
-- the occurrences in the large attribute case, even though
-- they will not actually be used.
-- To_Attribute_Handle conversions, since these are used only for small
-- attributes where we know that there are no problems with alignment, but
-- the compiler will generate warnings for the occurrences in the large
-- attribute case, even though they will not actually be used.
function To_Attribute_Handle is new Unchecked_Conversion
(System.Address, Attribute_Handle);
@ -327,10 +322,10 @@ package body Ada.Task_Attributes is
(Access_Dummy_Wrapper, Access_Wrapper);
pragma Warnings (On);
-- To fetch pointer to actual wrapper of attribute node. We turn off
-- warnings since this may generate an alignment warning. The warning
-- can be ignored since Dummy_Wrapper is only a non-generic standin
-- for the real wrapper type (we never actually allocate objects of
-- type Dummy_Wrapper).
-- warnings since this may generate an alignment warning. The warning can
-- be ignored since Dummy_Wrapper is only a non-generic standin for the
-- real wrapper type (we never actually allocate objects of type
-- Dummy_Wrapper).
function To_Access_Dummy_Wrapper is new Unchecked_Conversion
(Access_Wrapper, Access_Dummy_Wrapper);
@ -364,7 +359,7 @@ package body Ada.Task_Attributes is
-- Initialized in package body
type Wrapper is record
Noed : aliased Node;
Dummy_Node : aliased Node;
Value : aliased Attribute := Initial_Value;
-- The generic formal type, may be controlled
@ -450,7 +445,7 @@ package body Ada.Task_Attributes is
((null, Local'Unchecked_Access, null), Initial_Value);
POP.Lock_RTS;
P := W.Noed'Unchecked_Access;
P := W.Dummy_Node'Unchecked_Access;
P.Wrapper := To_Access_Dummy_Wrapper (W);
P.Next := To_Access_Node (TT.Indirect_Attributes);
TT.Indirect_Attributes := To_Access_Address (P);
@ -605,14 +600,14 @@ package body Ada.Task_Attributes is
P := P.Next;
end loop;
-- Unlock RTS here to follow the lock ordering rule that
-- prevent us from using new (i.e the Global_Lock) while
-- holding any other lock.
-- Unlock RTS here to follow the lock ordering rule that prevent us
-- from using new (i.e the Global_Lock) while holding any other
-- lock.
POP.Unlock_RTS;
W := new Wrapper'((null, Local'Unchecked_Access, null), Val);
POP.Lock_RTS;
P := W.Noed'Unchecked_Access;
P := W.Dummy_Node'Unchecked_Access;
P.Wrapper := To_Access_Dummy_Wrapper (W);
P.Next := To_Access_Node (TT.Indirect_Attributes);
TT.Indirect_Attributes := To_Access_Address (P);
@ -661,9 +656,9 @@ package body Ada.Task_Attributes is
if Local.Index /= 0 then
-- Get value of attribute. Warnings off, because for large
-- attributes, this code can generate alignment warnings.
-- But of course large attributes are never directly addressed
-- so in fact we will never execute the code in this case.
-- attributes, this code can generate alignment warnings. But of
-- course large attributes are never directly addressed so in fact
-- we will never execute the code in this case.
pragma Warnings (Off);
return To_Attribute_Handle
@ -734,13 +729,13 @@ begin
POP.Lock_RTS;
-- Add this instantiation to the list of all instantiations.
-- Add this instantiation to the list of all instantiations
Local.Next := System.Tasking.Task_Attributes.All_Attributes;
System.Tasking.Task_Attributes.All_Attributes :=
Local'Unchecked_Access;
-- Try to find space for the attribute in the TCB.
-- Try to find space for the attribute in the TCB
Local.Index := 0;
Two_To_J := 1;
@ -754,9 +749,9 @@ begin
In_Use := In_Use or Two_To_J;
Local.Index := J;
-- This unchecked conversions can give a warning when the
-- the alignment is incorrect, but it will not be used in
-- such a case anyway, so the warning can be safely ignored.
-- This unchecked conversions can give a warning when the the
-- alignment is incorrect, but it will not be used in such a
-- case anyway, so the warning can be safely ignored.
pragma Warnings (Off);
To_Attribute_Handle (Local.Initial_Value'Access).all :=
@ -773,13 +768,13 @@ begin
-- Attribute goes directly in the TCB
if Local.Index /= 0 then
-- Replace stub for initialization routine
-- that is called at task creation.
-- Replace stub for initialization routine that is called at task
-- creation.
Initialization.Initialize_Attributes_Link :=
System.Tasking.Task_Attributes.Initialize_Attributes'Access;
-- Initialize the attribute, for all tasks.
-- Initialize the attribute, for all tasks
declare
C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List;
@ -795,8 +790,8 @@ begin
-- Attribute goes into a node onto a linked list
else
-- Replace stub for finalization routine
-- that is called at task termination.
-- Replace stub for finalization routine that is called at task
-- termination.
Initialization.Finalize_Attributes_Link :=
System.Tasking.Task_Attributes.Finalize_Attributes'Access;

68
gcc/ada/comperr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 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- --
@ -20,7 +20,7 @@
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- Extensive contributions were provided by AdaCore. --
-- --
------------------------------------------------------------------------------
@ -78,7 +78,7 @@ package body Comperr is
-- the cause of the compiler abort and about the preferred method
-- of reporting bugs. The default is a bug box appropriate for
-- the FSF version of GNAT, but there are specializations for
-- the GNATPRO and Public releases by Ada Core Technologies.
-- the GNATPRO and Public releases by AdaCore.
procedure End_Line;
-- Add blanks up to column 76, and then a final vertical bar
@ -95,7 +95,6 @@ package body Comperr is
Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public;
Is_FSF_Version : constant Boolean := Get_Gnat_Build_Type = FSF;
Is_GAP_Version : constant Boolean := Get_Gnat_Build_Type = GAP;
-- Start of processing for Compiler_Abort
@ -268,22 +267,43 @@ package body Comperr is
" http://gcc.gnu.org/bugs.html.");
End_Line;
elsif Is_Public_Version then
Write_Str
("| submit bug report by email " &
"to report@adacore.com.");
End_Line;
Write_Str
("| See gnatinfo.txt for full info on procedure " &
"for submitting bugs.");
End_Line;
else
Write_Str
("| Please submit bug report by email " &
"to report@gnat.com.");
("| Please submit a bug report using GNAT Tracker:");
End_Line;
Write_Str
("| http://www.adacore.com/gnattracker/ " &
"section 'send a report'.");
End_Line;
Write_Str
("| alternatively submit a bug report by email " &
"to report@adacore.com.");
End_Line;
end if;
Write_Str
("| Use a subject line meaningful to you" &
" and us to track the bug.");
End_Line;
end if;
if not (Is_Public_Version or Is_FSF_Version) then
Write_Str
("| (include your customer number #nnn " &
"in the subject line).");
("| Include your customer number #nnn " &
"in the subject line.");
End_Line;
end if;
@ -305,35 +325,9 @@ package body Comperr is
("| (concatenated together with no headers between files).");
End_Line;
if Is_Public_Version then
if not Is_FSF_Version then
Write_Str
("| (use plain ASCII or MIME attachment).");
End_Line;
Write_Str
("| See gnatinfo.txt for full info on procedure " &
"for submitting bugs.");
End_Line;
elsif Is_GAP_Version then
Write_Str
("| (use plain ASCII or MIME attachment, or FTP "
& "to your GAP account.).");
End_Line;
Write_Str
("| Please use your GAP account to report this.");
End_Line;
elsif not Is_FSF_Version then
Write_Str
("| (use plain ASCII or MIME attachment, or FTP "
& "to your customer directory).");
End_Line;
Write_Str
("| See README.GNATPRO for full info on procedure " &
"for submitting bugs.");
("| Use plain ASCII or MIME attachment.");
End_Line;
end if;
end if;

5
gcc/ada/s-bitops.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1996-2005 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- --
@ -107,8 +107,7 @@ package body System.Bit_Ops is
(Left : Address;
Llen : Natural;
Right : Address;
Rlen : Natural)
return Boolean
Rlen : Natural) return Boolean
is
LeftB : constant Bits := To_Bits (Left);
RightB : constant Bits := To_Bits (Right);

8
gcc/ada/s-bitops.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -40,7 +40,8 @@ package System.Bit_Ops is
-- Note: in all the following routines, the System.Address parameters
-- represent the address of the first byte of an array used to represent
-- a packed array (of type System.Unsigned_Types.Packed_Bytes{1,2,4})
-- The length in bits is passed as a separate parameter.
-- The length in bits is passed as a separate parameter. Note that all
-- addresses must be of byte aligned arrays.
procedure Bit_And
(Left : System.Address;
@ -57,8 +58,7 @@ package System.Bit_Ops is
(Left : System.Address;
Llen : Natural;
Right : System.Address;
Rlen : Natural)
return Boolean;
Rlen : Natural) return Boolean;
-- Left and Right are the addresses of two bit packed arrays with Llen
-- and Rlen being the respective length in bits. The routine compares the
-- two bit strings for equality, being careful not to include the unused

6
gcc/ada/s-crtl.ads
View File

@ -139,6 +139,12 @@ pragma Preelaborate (CRTL);
function opendir (file_name : String) return DIRs;
pragma Import (C, opendir, "opendir");
function pclose (stream : System.Address) return int;
pragma Import (C, pclose, "pclose");
function popen (command, mode : System.Address) return System.Address;
pragma Import (C, popen, "popen");
function read (fd : int; buffer : chars; nbytes : int) return int;
pragma Import (C, read, "read");

9
gcc/ada/s-finimp.adb
View File

@ -383,19 +383,22 @@ package body System.Finalization_Implementation is
procedure Finalize_Global_List is
begin
-- There are three case here:
-- a. the application uses tasks, in which case Finalize_Global_Tasks
-- will defer abortion
-- will defer abort.
-- b. the application doesn't use tasks but uses other tasking
-- constructs, such as ATCs and protected objects. In this case,
-- the binder will call Finalize_Global_List instead of
-- Finalize_Global_Tasks, letting abort undeferred, and leading
-- to assertion failures in the GNULL
-- c. the application doesn't use any tasking construct in which case
-- deferring abort isn't necessary.
--
-- Until another solution is found to deal with case b, we need to
-- call abort_defer here to pass the checks, but we do not need to
-- undefer abortion, since Finalize_Global_List is the last procedure
-- undefer abort, since Finalize_Global_List is the last procedure
-- called before exiting the partition.
SSL.Abort_Defer.all;

107
gcc/ada/s-intman-vms.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1991-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1991-2005 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- --
@ -31,30 +31,31 @@
-- --
------------------------------------------------------------------------------
-- This is the Alpha/VMS version of this package.
--
-- This package encapsulates and centralizes information about
-- all uses of interrupts (or signals), including the
-- target-dependent mapping of interrupts (or signals) to exceptions.
-- This is the Alpha/VMS version of this package
-- PLEASE DO NOT add any with-clauses to this package.
-- This is designed to work for both tasking and non-tasking systems,
-- without pulling in any of the tasking support.
-- This package encapsulates and centralizes information about all uses of
-- interrupts (or signals), including the target-dependent mapping of
-- interrupts (or signals) to exceptions.
-- PLEASE DO NOT add any with-clauses to this package
-- This is designed to work for both tasking and non-tasking systems, without
-- pulling in any of the tasking support.
-- PLEASE DO NOT remove the Elaborate_Body pragma from this package.
-- Elaboration of this package should happen early, as most other
-- initializations depend on it.
-- Forcing immediate elaboration of the body also helps to enforce
-- the design assumption that this is a second-level
-- package, just one level above System.OS_Interface, with no
-- cross-dependences.
-- PLEASE DO NOT put any subprogram declarations with arguments of
-- type Interrupt_ID into the visible part of this package.
-- The type Interrupt_ID is used to derive the type in Ada.Interrupts,
-- and adding more operations to that type would be illegal according
-- to the Ada Reference Manual. (This is the reason why the signals sets
-- below are implemented as visible arrays rather than functions.)
-- Forcing immediate elaboration of the body also helps to enforce the design
-- assumption that this is a second-level package, just one level above
-- System.OS_Interface, with no cross-dependences.
-- PLEASE DO NOT put any subprogram declarations with arguments of type
-- Interrupt_ID into the visible part of this package.
-- The type Interrupt_ID is used to derive the type in Ada.Interrupts, and
-- adding more operations to that type would be illegal according to the Ada
-- Reference Manual. (This is the reason why the signals sets below are
-- implemented as visible arrays rather than functions.)
with System.OS_Interface;
-- used for Signal
@ -70,49 +71,44 @@ package System.Interrupt_Management is
type Interrupt_Set is array (Interrupt_ID) of Boolean;
-- The following objects serve as constants, but are initialized
-- in the body to aid portability. This permits us
-- to use more portable names for interrupts,
-- where distinct names may map to the same interrupt ID value.
-- For example, suppose SIGRARE is a signal that is not defined on
-- all systems, but is always reserved when it is defined.
-- If we have the convention that ID zero is not used for any "real"
-- signals, and SIGRARE = 0 when SIGRARE is not one of the locally
-- supported signals, we can write
-- The following objects serve as constants, but are initialized in the
-- body to aid portability. This permits us to use more portable names for
-- interrupts, where distinct names may map to the same interrupt ID
-- value. For example, suppose SIGRARE is a signal that is not defined on
-- all systems, but is always reserved when it is defined. If we have the
-- convention that ID zero is not used for any "real" signals, and SIGRARE
-- = 0 when SIGRARE is not one of the locally supported signals, we can
-- write
-- Reserved (SIGRARE) := true;
-- and the initialization code will be portable.
-- Then the initialization code will be portable
Abort_Task_Interrupt : Interrupt_ID;
-- The interrupt that is used to implement task abortion,
-- if an interrupt is used for that purpose.
-- This is one of the reserved interrupts.
-- The interrupt that is used to implement task abort, if an interrupt is
-- used for that purpose. This is one of the reserved interrupts.
Keep_Unmasked : Interrupt_Set := (others => False);
-- Keep_Unmasked (I) is true iff the interrupt I is
-- one that must be kept unmasked at all times,
-- except (perhaps) for short critical sections.
-- This includes interrupts that are mapped to exceptions
-- (see System.Interrupt_Exceptions.Is_Exception), but may also
-- include interrupts (e.g. timer) that need to be kept unmasked
-- for other reasons.
-- Where interrupts are implemented as OS signals, and signal masking
-- is per-task, the interrupt should be unmasked in ALL TASKS.
-- Keep_Unmasked (I) is true iff the interrupt I is one that must be kept
-- unmasked at all times, except (perhaps) for short critical sections.
-- This includes interrupts that are mapped to exceptions (see
-- System.Interrupt_Exceptions.Is_Exception), but may also include
-- interrupts (e.g. timer) that need to be kept unmasked for other
-- reasons. Where interrupts are implemented as OS signals, and signal
-- masking is per-task, the interrupt should be unmasked in ALL TASKS.
Reserve : Interrupt_Set := (others => False);
-- Reserve (I) is true iff the interrupt I is one that
-- cannot be permitted to be attached to a user handler.
-- The possible reasons are many. For example,
-- it may be mapped to an exception, used to implement task abortion,
-- or used to implement time delays.
-- Reserve (I) is true iff the interrupt I is one that cannot be permitted
-- to be attached to a user handler. The possible reasons are many. For
-- example it may be mapped to an exception used to implement task abort.
Keep_Masked : Interrupt_Set := (others => False);
-- Keep_Masked (I) is true iff the interrupt I must always be masked.
-- Where interrupts are implemented as OS signals, and signal masking
-- is per-task, the interrupt should be masked in ALL TASKS.
-- There might not be any interrupts in this class, depending on
-- the environment. For example, if interrupts are OS signals
-- and signal masking is per-task, use of the sigwait operation
-- requires the signal be masked in all tasks.
-- Where interrupts are implemented as OS signals, and signal masking is
-- per-task, the interrupt should be masked in ALL TASKS. There might not
-- be any interrupts in this class, depending on the environment. For
-- example, if interrupts are OS signals and signal masking is per-task,
-- use of the sigwait operation requires the signal be masked in all tasks.
procedure Initialize_Interrupts;
-- On systems where there is no signal inheritance between tasks (e.g
@ -121,7 +117,6 @@ package System.Interrupt_Management is
-- only be called by initialize in this package body.
private
use type System.OS_Interface.unsigned_long;
type Interrupt_Mask is new System.OS_Interface.sigset_t;
@ -136,7 +131,7 @@ private
Rcv_Interrupt_Chan : System.OS_Interface.unsigned_short := 0;
Snd_Interrupt_Chan : System.OS_Interface.unsigned_short := 0;
Interrupt_Mailbox : Interrupt_ID := 0;
Interrupt_Bufquo : System.OS_Interface.unsigned_long
:= 1000 * (Interrupt_ID'Size / 8);
Interrupt_Bufquo : System.OS_Interface.unsigned_long :=
1000 * (Interrupt_ID'Size / 8);
end System.Interrupt_Management;

58
gcc/ada/s-intman-vxworks.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 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- --
@ -31,7 +31,7 @@
-- --
------------------------------------------------------------------------------
-- This is the VxWorks version of this package.
-- This is the VxWorks version of this package
-- This package encapsulates and centralizes information about all
-- uses of interrupts (or signals), including the target-dependent
@ -76,48 +76,48 @@ package System.Interrupt_Management is
type Signal_Set is array (Signal_ID) of Boolean;
-- The following objects serve as constants, but are initialized
-- in the body to aid portability. This permits us to use more
-- portable names for interrupts, where distinct names may map to
-- the same interrupt ID value.
--
-- For example, suppose SIGRARE is a signal that is not defined on
-- all systems, but is always reserved when it is defined. If we
-- have the convention that ID zero is not used for any "real"
-- signals, and SIGRARE = 0 when SIGRARE is not one of the locally
-- supported signals, we can write
-- The following objects serve as constants, but are initialized in the
-- body to aid portability. This permits us to use more portable names for
-- interrupts, where distinct names may map to the same interrupt ID
-- value.
-- For example, suppose SIGRARE is a signal that is not defined on all
-- systems, but is always reserved when it is defined. If we have the
-- convention that ID zero is not used for any "real" signals, and SIGRARE
-- = 0 when SIGRARE is not one of the locally supported signals, we can
-- write:
-- Reserved (SIGRARE) := true;
-- and the initialization code will be portable.
Abort_Task_Signal : Signal_ID;
-- The signal that is used to implement task abortion if
-- an interrupt is used for that purpose. This is one of the
-- reserved signals.
-- The signal that is used to implement task abort if an interrupt is used
-- for that purpose. This is one of the reserved signals.
Keep_Unmasked : Signal_Set := (others => False);
-- Keep_Unmasked (I) is true iff the signal I is one that must
-- that must be kept unmasked at all times, except (perhaps) for
-- short critical sections. This includes signals that are
-- mapped to exceptions, but may also include interrupts
-- (e.g. timer) that need to be kept unmasked for other
-- reasons. Where signal masking is per-task, the signal should be
-- Keep_Unmasked (I) is true iff the signal I is one that must that must
-- be kept unmasked at all times, except (perhaps) for short critical
-- sections. This includes signals that are mapped to exceptions, but may
-- also include interrupts (e.g. timer) that need to be kept unmasked for
-- other reasons. Where signal masking is per-task, the signal should be
-- unmasked in ALL TASKS.
Reserve : Interrupt_Set := (others => False);
-- Reserve (I) is true iff the interrupt I is one that cannot be
-- permitted to be attached to a user handler. The possible reasons
-- are many. For example, it may be mapped to an exception used to
-- implement task abortion, or used to implement time delays.
-- Reserve (I) is true iff the interrupt I is one that cannot be permitted
-- to be attached to a user handler. The possible reasons are many. For
-- example, it may be mapped to an exception used to implement task abort,
-- or used to implement time delays.
procedure Initialize_Interrupts;
-- On systems where there is no signal inheritance between tasks (e.g
-- VxWorks, GNU/LinuxThreads), this procedure is used to initialize
-- interrupts handling in each task. Otherwise this function should
-- only be called by initialize in this package body.
-- interrupts handling in each task. Otherwise this function should only
-- be called by initialize in this package body.
private
type Interrupt_Mask is new System.OS_Interface.sigset_t;
-- In some implementation Interrupt_Mask can be represented
-- as a linked list.
-- In some implementation Interrupt_Mask can be represented as a linked
-- list.
end System.Interrupt_Management;

92
gcc/ada/s-intman.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 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- --
@ -31,26 +31,26 @@
-- --
------------------------------------------------------------------------------
-- This package encapsulates and centralizes information about all
-- uses of interrupts (or signals), including the target-dependent
-- mapping of interrupts (or signals) to exceptions.
-- This package encapsulates and centralizes information about all uses of
-- interrupts (or signals), including the target-dependent mapping of
-- interrupts (or signals) to exceptions.
-- Unlike the original design, System.Interrupt_Management can only
-- be used for tasking systems.
-- Unlike the original design, System.Interrupt_Management can only be used
-- for tasking systems.
-- PLEASE DO NOT remove the Elaborate_Body pragma from this package.
-- Elaboration of this package should happen early, as most other
-- initializations depend on it. Forcing immediate elaboration of
-- the body also helps to enforce the design assumption that this
-- is a second-level package, just one level above System.OS_Interface
-- with no cross-dependencies.
-- initializations depend on it. Forcing immediate elaboration of the body
-- also helps to enforce the design assumption that this is a second-level
-- package, just one level above System.OS_Interface with no
-- cross-dependencies.
-- PLEASE DO NOT put any subprogram declarations with arguments of
-- type Interrupt_ID into the visible part of this package. The type
-- Interrupt_ID is used to derive the type in Ada.Interrupts, and
-- adding more operations to that type would be illegal according
-- to the Ada Reference Manual. This is the reason why the signals
-- sets are implemeneted using visible arrays rather than functions.
-- PLEASE DO NOT put any subprogram declarations with arguments of type
-- Interrupt_ID into the visible part of this package. The type Interrupt_ID
-- is used to derive the type in Ada.Interrupts, and adding more operations
-- to that type would be illegal according to the Ada Reference Manual. This
-- is the reason why the signals sets are implemeneted using visible arrays
-- rather than functions.
with System.OS_Interface;
-- used for sigset_t
@ -69,49 +69,49 @@ package System.Interrupt_Management is
type Interrupt_Set is array (Interrupt_ID) of Boolean;
-- The following objects serve as constants, but are initialized
-- in the body to aid portability. This permits us to use more
-- portable names for interrupts, where distinct names may map to
-- the same interrupt ID value.
--
-- For example, suppose SIGRARE is a signal that is not defined on
-- all systems, but is always reserved when it is defined. If we
-- have the convention that ID zero is not used for any "real"
-- signals, and SIGRARE = 0 when SIGRARE is not one of the locally
-- supported signals, we can write
-- Reserved (SIGRARE) := true;
-- The following objects serve as constants, but are initialized in the
-- body to aid portability. This permits us to use more portable names for
-- interrupts, where distinct names may map to the same interrupt ID
-- value.
-- For example, suppose SIGRARE is a signal that is not defined on all
-- systems, but is always reserved when it is defined. If we have the
-- convention that ID zero is not used for any "real" signals, and SIGRARE
-- = 0 when SIGRARE is not one of the locally supported signals, we can
-- write
-- Reserved (SIGRARE) := True;
-- and the initialization code will be portable.
Abort_Task_Interrupt : Interrupt_ID;
-- The interrupt that is used to implement task abortion if
-- an interrupt is used for that purpose. This is one of the
-- reserved interrupts.
-- The interrupt that is used to implement task abort if an interrupt is
-- used for that purpose. This is one of the reserved interrupts.
Keep_Unmasked : Interrupt_Set := (others => False);
-- Keep_Unmasked (I) is true iff the interrupt I is one that must
-- that must be kept unmasked at all times, except (perhaps) for
-- short critical sections. This includes interrupts that are
-- mapped to exceptions (see System.Interrupt_Exceptions.Is_Exception),
-- but may also include interrupts (e.g. timer) that need to be kept
-- unmasked for other reasons. Where interrupts are implemented as
-- OS signals, and signal masking is per-task, the interrupt should
-- be unmasked in ALL TASKS.
-- Keep_Unmasked (I) is true iff the interrupt I is one that must that
-- must be kept unmasked at all times, except (perhaps) for short critical
-- sections. This includes interrupts that are mapped to exceptions (see
-- System.Interrupt_Exceptions.Is_Exception), but may also include
-- interrupts (e.g. timer) that need to be kept unmasked for other
-- reasons. Where interrupts are implemented as OS signals, and signal
-- masking is per-task, the interrupt should be unmasked in ALL TASKS.
Reserve : Interrupt_Set := (others => False);
-- Reserve (I) is true iff the interrupt I is one that cannot be
-- permitted to be attached to a user handler. The possible reasons
-- are many. For example, it may be mapped to an exception used to
-- implement task abortion, or used to implement time delays.
-- Reserve (I) is true iff the interrupt I is one that cannot be permitted
-- to be attached to a user handler. The possible reasons are many. For
-- example, it may be mapped to an exception used to implement task abort,
-- or used to implement time delays.
procedure Initialize_Interrupts;
-- On systems where there is no signal inheritance between tasks (e.g
-- VxWorks, GNU/LinuxThreads), this procedure is used to initialize
-- interrupts handling in each task. Otherwise this function should
-- only be called by initialize in this package body.
-- interrupts handling in each task. Otherwise this function should only
-- be called by initialize in this package body.
private
type Interrupt_Mask is new System.OS_Interface.sigset_t;
-- In some implementation Interrupt_Mask can be represented
-- as a linked list.
-- In some implementations Interrupt_Mask can be represented as a linked
-- list.
end System.Interrupt_Management;

14
gcc/ada/s-memory.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
-- Copyright (C) 2001-2005 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- --
@ -35,13 +35,13 @@
-- This implementation assumes that the underlying malloc/free/realloc
-- implementation is thread safe, and thus, no additional lock is required.
-- Note that we still need to defer abortion because on most systems,
-- an asynchronous signal (as used for implementing asynchronous abortion
-- of task) cannot safely be handled while malloc is executing.
-- Note that we still need to defer abort because on most systems, an
-- asynchronous signal (as used for implementing asynchronous abort of
-- task) cannot safely be handled while malloc is executing.
-- If you are not using Ada constructs containing the "abort" keyword,
-- then you can remove the calls to Abort_Defer.all and Abort_Undefer.all
-- from this unit.
-- If you are not using Ada constructs containing the "abort" keyword, then
-- you can remove the calls to Abort_Defer.all and Abort_Undefer.all from
-- this unit.
with Ada.Exceptions;
with System.Soft_Links;

26
gcc/ada/s-soflin.ads
View File

@ -52,7 +52,7 @@ package System.Soft_Links is
pragma Import
(Ada, Current_Target_Exception,
"__gnat_current_target_exception");
-- Import this subprogram from the private part of Ada.Exceptions.
-- Import this subprogram from the private part of Ada.Exceptions
-- First we have the access subprogram types used to establish the links.
-- The approach is to establish variables containing access subprogram
@ -112,20 +112,20 @@ package System.Soft_Links is
-- Declarations for the no tasking versions of the required routines
procedure Abort_Defer_NT;
-- Defer task abortion (non-tasking case, does nothing)
-- Defer task abort (non-tasking case, does nothing)
procedure Abort_Undefer_NT;
-- Undefer task abortion (non-tasking case, does nothing)
-- Undefer task abort (non-tasking case, does nothing)
procedure Abort_Handler_NT;
-- Handle task abortion (non-tasking case, does nothing). Currently,
-- only VMS uses this.
-- Handle task abort (non-tasking case, does nothing). Currently, only VMS
-- uses this.
procedure Update_Exception_NT (X : EO := Current_Target_Exception);
-- Handle exception setting. This routine is provided for targets
-- which have built-in exception handling such as the Java Virtual
-- Machine. Currently, only JGNAT uses this. See 4jexcept.ads for
-- an explanation on how this routine is used.
-- Handle exception setting. This routine is provided for targets which
-- have built-in exception handling such as the Java Virtual Machine.
-- Currently, only JGNAT uses this. See 4jexcept.ads for an explanation on
-- how this routine is used.
function Check_Abort_Status_NT return Integer;
-- Returns Boolean'Pos (True) iff abort signal should raise
@ -143,14 +143,14 @@ package System.Soft_Links is
Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access;
pragma Suppress (Access_Check, Abort_Defer);
-- Defer task abortion (task/non-task case as appropriate)
-- Defer task abort (task/non-task case as appropriate)
Abort_Undefer : No_Param_Proc := Abort_Undefer_NT'Access;
pragma Suppress (Access_Check, Abort_Undefer);
-- Undefer task abortion (task/non-task case as appropriate)
-- Undefer task abort (task/non-task case as appropriate)
Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access;
-- Handle task abortion (task/non-task case as appropriate)
-- Handle task abort (task/non-task case as appropriate)
Update_Exception : Special_EO_Call := Update_Exception_NT'Access;
-- Handle exception setting and tasking polling when appropriate
@ -196,7 +196,7 @@ package System.Soft_Links is
-- explicitly or implicitly during the critical locked region.
Adafinal : No_Param_Proc := Null_Adafinal'Access;
-- Performs the finalization of the Ada Runtime.
-- Performs the finalization of the Ada Runtime
function Get_Jmpbuf_Address_NT return Address;
procedure Set_Jmpbuf_Address_NT (Addr : Address);

10
gcc/ada/s-taasde.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1998-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1998-2005 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- --
@ -31,8 +31,8 @@
-- --
------------------------------------------------------------------------------
-- This package contains the procedures to implements timeouts (delays)
-- for asynchronous select statements.
-- This package contains the procedures to implements timeouts (delays) for
-- asynchronous select statements.
-- Note: the compiler generates direct calls to this interface, via Rtsfind.
-- Any changes to this interface may require corresponding compiler changes.
@ -100,8 +100,8 @@ package System.Tasking.Async_Delays is
(T : in Duration;
D : Delay_Block_Access) return Boolean;
-- Enqueue the specified relative delay. Returns True if the delay has
-- been enqueued, False if it has already expired.
-- If the delay has been enqueued, abortion is deferred.
-- been enqueued, False if it has already expired. If the delay has been
-- enqueued, abort is deferred.
procedure Cancel_Async_Delay (D : Delay_Block_Access);
-- Cancel the specified asynchronous delay

14
gcc/ada/s-taprob.adb
View File

@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2004, Ada Core Technologies --
-- Copyright (C) 1995-2005, Ada Core Technologies --
-- --
-- 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- --
@ -90,15 +90,15 @@ package body System.Tasking.Protected_Objects is
Ceiling_Violation : Boolean;
begin
-- The lock is made without defering abortion.
-- The lock is made without defering abort
-- Therefore the abortion has to be deferred before calling this
-- routine. This means that the compiler has to generate a Defer_Abort
-- call before the call to Lock.
-- Therefore the abort has to be deferred before calling this routine.
-- This means that the compiler has to generate a Defer_Abort call
-- before the call to Lock.
-- The caller is responsible for undeferring abortion, and compiler
-- The caller is responsible for undeferring abort, and compiler
-- generated calls must be protected with cleanup handlers to ensure
-- that abortion is undeferred in all cases.
-- that abort is undeferred in all cases.
Write_Lock (Object.L'Access, Ceiling_Violation);

26
gcc/ada/s-taprop-os2.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -112,7 +112,7 @@ package body System.Task_Primitives.Operations is
-- Local Data --
-----------------
-- The OS/2 DosAllocThreadLocalMemory API is used to allocate our TCB_Ptr.
-- The OS/2 DosAllocThreadLocalMemory API is used to allocate our TCB_Ptr
-- This API reserves a small range of virtual addresses that is backed
-- by different physical memory for each running thread. In this case we
@ -141,7 +141,7 @@ package body System.Task_Primitives.Operations is
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task.
-- A variable to hold Task_Id for the environment task
-----------------------
-- Local Subprograms --
@ -223,7 +223,7 @@ package body System.Task_Primitives.Operations is
Self_ID : Task_Id renames Thread_Local_Data_Ptr.Self_ID;
begin
-- Check that the thread local data has been initialized.
-- Check that the thread local data has been initialized
pragma Assert
((Thread_Local_Data_Ptr /= null
@ -458,7 +458,7 @@ package body System.Task_Primitives.Operations is
Count : aliased ULONG; -- Used to store dummy result
begin
-- Must reset Cond BEFORE L is unlocked.
-- Must reset Cond BEFORE L is unlocked
Sem_Must_Not_Fail
(DosResetEventSem (Self_ID.Common.LL.CV, Count'Unchecked_Access));
@ -475,7 +475,7 @@ package body System.Task_Primitives.Operations is
Sem_Must_Not_Fail
(DosWaitEventSem (Self_ID.Common.LL.CV, SEM_INDEFINITE_WAIT));
-- Since L was previously accquired, lock operation should not fail.
-- Since L was previously accquired, lock operation should not fail
if Single_Lock then
Lock_RTS;
@ -516,7 +516,7 @@ package body System.Task_Primitives.Operations is
Count : aliased ULONG; -- Used to store dummy result
begin
-- Must reset Cond BEFORE Self_ID is unlocked.
-- Must reset Cond BEFORE Self_ID is unlocked
Sem_Must_Not_Fail
(DosResetEventSem (Self_ID.Common.LL.CV,
@ -611,7 +611,7 @@ package body System.Task_Primitives.Operations is
Write_Lock (Self_ID);
end if;
-- Must reset Cond BEFORE Self_ID is unlocked.
-- Must reset Cond BEFORE Self_ID is unlocked
Sem_Must_Not_Fail
(DosResetEventSem (Self_ID.Common.LL.CV,
@ -767,7 +767,7 @@ package body System.Task_Primitives.Operations is
procedure Enter_Task (Self_ID : Task_Id) is
begin
-- Initialize thread local data. Must be done first.
-- Initialize thread local data. Must be done first
Thread_Local_Data_Ptr.Self_ID := Self_ID;
Thread_Local_Data_Ptr.Lock_Prio_Level := 0;
@ -927,7 +927,7 @@ package body System.Task_Primitives.Operations is
T.Common.LL.Wrapper := To_PFNTHREAD (Wrapper);
-- The OS implicitly gives the new task the priority of this task.
-- The OS implicitly gives the new task the priority of this task
T.Common.LL.Current_Priority := Self.Common.LL.Current_Priority;
@ -1007,7 +1007,7 @@ package body System.Task_Primitives.Operations is
begin
null;
-- Task abortion not implemented yet.
-- Task abort not implemented yet.
-- Should perform other action ???
end Abort_Task;
@ -1103,9 +1103,9 @@ package body System.Task_Primitives.Operations is
Environment_Task_Id := Environment_Task;
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-- Initialize the lock used to synchronize chain of all ATCBs.
-- Initialize the lock used to synchronize chain of all ATCBs
-- Set ID of environment task.
-- Set ID of environment task
Thread_Local_Data_Ptr.Self_ID := Environment_Task;
Environment_Task.Common.LL.Thread := 1; -- By definition

131
gcc/ada/s-taprop-vxworks.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -91,12 +91,12 @@ package body System.Task_Primitives.Operations is
-- Local Data --
----------------
-- The followings are logically constants, but need to be initialized
-- at run time.
-- The followings are logically constants, but need to be initialized at
-- run time.
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- This is a lock to allow only one thread of control in the RTS at a
-- time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
ATCB_Key : aliased System.Address := System.Null_Address;
@ -109,12 +109,12 @@ package body System.Task_Primitives.Operations is
-- targets.
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task.
-- A variable to hold Task_Id for the environment task
Unblocked_Signal_Mask : aliased sigset_t;
-- The set of signals that should unblocked in all tasks
-- The followings are internal configuration constants needed.
-- The followings are internal configuration constants needed
Time_Slice_Val : Integer;
pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
@ -126,12 +126,12 @@ package body System.Task_Primitives.Operations is
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
-- Indicates whether FIFO_Within_Priorities is set.
-- Indicates whether FIFO_Within_Priorities is set
Mutex_Protocol : Priority_Type;
Foreign_Task_Elaborated : aliased Boolean := True;
-- Used to identified fake tasks (i.e., non-Ada Threads).
-- Used to identified fake tasks (i.e., non-Ada Threads)
--------------------
-- Local Packages --
@ -145,23 +145,23 @@ package body System.Task_Primitives.Operations is
procedure Set (Self_Id : Task_Id);
pragma Inline (Set);
-- Set the self id for the current task.
-- Set the self id for the current task
function Self return Task_Id;
pragma Inline (Self);
-- Return a pointer to the Ada Task Control Block of the calling task.
-- Return a pointer to the Ada Task Control Block of the calling task
end Specific;
package body Specific is separate;
-- The body of this package is target specific.
-- The body of this package is target specific
---------------------------------
-- Support for foreign threads --
---------------------------------
function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
-- Allocate and Initialize a new ATCB for the current Thread.
-- Allocate and Initialize a new ATCB for the current Thread
function Register_Foreign_Thread
(Thread : Thread_Id) return Task_Id is separate;
@ -171,7 +171,7 @@ package body System.Task_Primitives.Operations is
-----------------------
procedure Abort_Handler (signo : Signal);
-- Handler for the abort (SIGABRT) signal to handle asynchronous abortion.
-- Handler for the abort (SIGABRT) signal to handle asynchronous abort
procedure Install_Signal_Handlers;
-- Install the default signal handlers for the current task
@ -409,7 +409,8 @@ package body System.Task_Primitives.Operations is
begin
pragma Assert (Self_ID = Self);
-- Release the mutex before sleeping.
-- Release the mutex before sleeping
if Single_Lock then
Result := semGive (Single_RTS_Lock.Mutex);
else
@ -418,15 +419,16 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
-- Perform a blocking operation to take the CV semaphore.
-- Note that a blocking operation in VxWorks will reenable
-- task scheduling. When we are no longer blocked and control
-- is returned, task scheduling will again be disabled.
-- Perform a blocking operation to take the CV semaphore. Note that a
-- blocking operation in VxWorks will reenable task scheduling. When we
-- are no longer blocked and control is returned, task scheduling will
-- again be disabled.
Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER);
pragma Assert (Result = 0);
-- Take the mutex back.
-- Take the mutex back
if Single_Lock then
Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
else
@ -440,9 +442,8 @@ package body System.Task_Primitives.Operations is
-- Timed_Sleep --
-----------------
-- This is for use within the run-time system, so abort is
-- assumed to be already deferred, and the caller should be
-- holding its own ATCB lock.
-- This is for use within the run-time system, so abort is assumed to be
-- already deferred, and the caller should be holding its own ATCB lock.
procedure Timed_Sleep
(Self_ID : Task_Id;
@ -467,9 +468,9 @@ package body System.Task_Primitives.Operations is
if Mode = Relative then
Absolute := Orig + Time;
-- Systematically add one since the first tick will delay
-- *at most* 1 / Rate_Duration seconds, so we need to add one to
-- be on the safe side.
-- Systematically add one since the first tick will delay *at most*
-- 1 / Rate_Duration seconds, so we need to add one to be on the
-- safe side.
Ticks := To_Clock_Ticks (Time);
@ -484,7 +485,8 @@ package body System.Task_Primitives.Operations is
if Ticks > 0 then
loop
-- Release the mutex before sleeping.
-- Release the mutex before sleeping
if Single_Lock then
Result := semGive (Single_RTS_Lock.Mutex);
else
@ -493,14 +495,15 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
-- Perform a blocking operation to take the CV semaphore.
-- Note that a blocking operation in VxWorks will reenable
-- task scheduling. When we are no longer blocked and control
-- is returned, task scheduling will again be disabled.
-- Perform a blocking operation to take the CV semaphore. Note
-- that a blocking operation in VxWorks will reenable task
-- scheduling. When we are no longer blocked and control is
-- returned, task scheduling will again be disabled.
Result := semTake (Self_ID.Common.LL.CV, Ticks);
if Result = 0 then
-- Somebody may have called Wakeup for us
Wakeup := True;
@ -508,10 +511,11 @@ package body System.Task_Primitives.Operations is
else
if errno /= S_objLib_OBJ_TIMEOUT then
Wakeup := True;
else
-- If Ticks = int'last, it was most probably truncated
-- so let's make another round after recomputing Ticks
-- from the the absolute time.
-- If Ticks = int'last, it was most probably truncated so
-- let's make another round after recomputing Ticks from
-- the the absolute time.
if Ticks /= int'Last then
Timedout := True;
@ -525,7 +529,8 @@ package body System.Task_Primitives.Operations is
end if;
end if;
-- Take the mutex back.
-- Take the mutex back
if Single_Lock then
Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
else
@ -540,7 +545,8 @@ package body System.Task_Primitives.Operations is
else
Timedout := True;
-- Should never hold a lock while yielding.
-- Should never hold a lock while yielding
if Single_Lock then
Result := semGive (Single_RTS_Lock.Mutex);
taskDelay (0);
@ -558,8 +564,8 @@ package body System.Task_Primitives.Operations is
-- Timed_Delay --
-----------------
-- This is for use in implementing delay statements, so
-- we assume the caller is holding no locks.
-- This is for use in implementing delay statements, so we assume the
-- caller is holding no locks.
procedure Timed_Delay
(Self_ID : Task_Id;
@ -582,9 +588,8 @@ package body System.Task_Primitives.Operations is
if Ticks > 0 and then Ticks < int'Last then
-- The first tick will delay anytime between 0 and
-- 1 / sysClkRateGet seconds, so we need to add one to
-- be on the safe side.
-- First tick will delay anytime between 0 and 1 / sysClkRateGet
-- seconds, so we need to add one to be on the safe side.
Ticks := Ticks + 1;
end if;
@ -595,7 +600,9 @@ package body System.Task_Primitives.Operations is
end if;
if Ticks > 0 then
-- Modifying State and Pending_Priority_Change, locking the TCB.
-- Modifying State and Pending_Priority_Change, locking the TCB
if Single_Lock then
Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
else
@ -630,6 +637,7 @@ package body System.Task_Primitives.Operations is
Result := semTake (Self_ID.Common.LL.CV, Ticks);
if Result /= 0 then
-- If Ticks = int'last, it was most probably truncated
-- so let's make another round after recomputing Ticks
-- from the the absolute time.
@ -749,6 +757,7 @@ package body System.Task_Primitives.Operations is
if FIFO_Within_Priorities then
-- Annex D requirement [RM D.2.2 par. 9]:
-- If the task drops its priority due to the loss of inherited
-- priority, it is added at the head of the ready queue for its
-- new active priority.
@ -794,7 +803,7 @@ package body System.Task_Primitives.Operations is
procedure Enter_Task (Self_ID : Task_Id) is
procedure Init_Float;
pragma Import (C, Init_Float, "__gnat_init_float");
-- Properly initializes the FPU for PPC/MIPS systems.
-- Properly initializes the FPU for PPC/MIPS systems
begin
Self_ID.Common.LL.Thread := taskIdSelf;
@ -802,7 +811,8 @@ package body System.Task_Primitives.Operations is
Init_Float;
-- Install the signal handlers.
-- Install the signal handlers
-- This is called for each task since there is no signal inheritance
-- between VxWorks tasks.
@ -892,28 +902,26 @@ package body System.Task_Primitives.Operations is
Adjusted_Stack_Size := size_t (Stack_Size);
end if;
-- Ask for 4 extra bytes of stack space so that the ATCB
-- pointer can be stored below the stack limit, plus extra
-- space for the frame of Task_Wrapper. This is so the user
-- gets the amount of stack requested exclusive of the needs
-- of the runtime.
-- Ask for four extra bytes of stack space so that the ATCB pointer can
-- be stored below the stack limit, plus extra space for the frame of
-- Task_Wrapper. This is so the user gets the amount of stack requested
-- exclusive of the needs
--
-- We also have to allocate n more bytes for the task name
-- storage and enough space for the Wind Task Control Block
-- which is around 0x778 bytes. VxWorks also seems to carve out
-- additional space, so use 2048 as a nice round number.
-- We might want to increment to the nearest page size in
-- case we ever support VxVMI.
-- We also have to allocate n more bytes for the task name storage and
-- enough space for the Wind Task Control Block which is around 0x778
-- bytes. VxWorks also seems to carve out additional space, so use 2048
-- as a nice round number. We might want to increment to the nearest
-- page size in case we ever support VxVMI.
--
-- XXX - we should come back and visit this so we can
-- set the task name to something appropriate.
-- XXX - we should come back and visit this so we can set the task name
-- to something appropriate.
Adjusted_Stack_Size := Adjusted_Stack_Size + 2048;
-- Since the initial signal mask of a thread is inherited from the
-- creator, and the Environment task has all its signals masked, we
-- do not need to manipulate caller's signal mask at this point.
-- All tasks in RTS will have All_Tasks_Mask initially.
-- creator, and the Environment task has all its signals masked, we do
-- not need to manipulate caller's signal mask at this point. All tasks
-- in RTS will have All_Tasks_Mask initially.
if T.Common.Task_Image_Len = 0 then
T.Common.LL.Thread := taskSpawn
@ -926,6 +934,7 @@ package body System.Task_Primitives.Operations is
else
declare
Name : aliased String (1 .. T.Common.Task_Image_Len + 1);
begin
Name (1 .. Name'Last - 1) :=
T.Common.Task_Image (1 .. T.Common.Task_Image_Len);
@ -1127,7 +1136,7 @@ package body System.Task_Primitives.Operations is
Environment_Task_Id := Environment_Task;
-- Initialize the lock used to synchronize chain of all ATCBs.
-- Initialize the lock used to synchronize chain of all ATCBs
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);

238
gcc/ada/s-taprop.ads
View File

@ -82,23 +82,21 @@ package System.Task_Primitives.Operations is
procedure Enter_Task (Self_ID : ST.Task_Id);
pragma Inline (Enter_Task);
-- Initialize data structures specific to the calling task.
-- Self must be the ID of the calling task.
-- It must be called (once) by the task immediately after creation,
-- while abortion is still deferred.
-- The effects of other operations defined below are not defined
-- unless the caller has previously called Initialize_Task.
-- Initialize data structures specific to the calling task. Self must be
-- the ID of the calling task. It must be called (once) by the task
-- immediately after creation, while abort is still deferred. The effects
-- of other operations defined below are not defined unless the caller has
-- previously called Initialize_Task.
procedure Exit_Task;
pragma Inline (Exit_Task);
-- Destroy the thread of control.
-- Self must be the ID of the calling task.
-- The effects of further calls to operations defined below
-- on the task are undefined thereafter.
-- Destroy the thread of control. Self must be the ID of the calling task.
-- The effects of further calls to operations defined below on the task
-- are undefined thereafter.
function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_Id;
pragma Inline (New_ATCB);
-- Allocate a new ATCB with the specified number of entries.
-- Allocate a new ATCB with the specified number of entries
procedure Initialize_TCB (Self_ID : ST.Task_Id; Succeeded : out Boolean);
pragma Inline (Initialize_TCB);
@ -106,19 +104,17 @@ package System.Task_Primitives.Operations is
procedure Finalize_TCB (T : ST.Task_Id);
pragma Inline (Finalize_TCB);
-- Finalizes Private_Data of ATCB, and then deallocates it.
-- This is also responsible for recovering any storage or other resources
-- that were allocated by Create_Task (the one in this package).
-- This should only be called from Free_Task.
-- After it is called there should be no further
-- Finalizes Private_Data of ATCB, and then deallocates it. This is also
-- responsible for recovering any storage or other resources that were
-- allocated by Create_Task (the one in this package). This should only be
-- called from Free_Task. After it is called there should be no further
-- reference to the ATCB that corresponds to T.
procedure Abort_Task (T : ST.Task_Id);
pragma Inline (Abort_Task);
-- Abort the task specified by T (the target task). This causes
-- the target task to asynchronously raise Abort_Signal if
-- abort is not deferred, or if it is blocked on an interruptible
-- system call.
-- Abort the task specified by T (the target task). This causes the target
-- task to asynchronously raise Abort_Signal if abort is not deferred, or
-- if it is blocked on an interruptible system call.
--
-- precondition:
-- the calling task is holding T's lock and has abort deferred
@ -130,7 +126,7 @@ package System.Task_Primitives.Operations is
function Self return ST.Task_Id;
pragma Inline (Self);
-- Return a pointer to the Ada Task Control Block of the calling task.
-- Return a pointer to the Ada Task Control Block of the calling task
type Lock_Level is
(PO_Level,
@ -138,27 +134,27 @@ package System.Task_Primitives.Operations is
RTS_Lock_Level,
ATCB_Level);
-- Type used to describe kind of lock for second form of Initialize_Lock
-- call specified below.
-- See locking rules in System.Tasking (spec) for more details.
-- call specified below. See locking rules in System.Tasking (spec) for
-- more details.
procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock);
procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level);
pragma Inline (Initialize_Lock);
-- Initialize a lock object.
--
-- For Lock, Prio is the ceiling priority associated with the lock.
-- For RTS_Lock, the ceiling is implicitly Priority'Last.
-- For Lock, Prio is the ceiling priority associated with the lock. For
-- RTS_Lock, the ceiling is implicitly Priority'Last.
--
-- If the underlying system does not support priority ceiling
-- locking, the Prio parameter is ignored.
--
-- The effect of either initialize operation is undefined unless L
-- is a lock object that has not been initialized, or which has been
-- finalized since it was last initialized.
-- The effect of either initialize operation is undefined unless is a lock
-- object that has not been initialized, or which has been finalized since
-- it was last initialized.
--
-- The effects of the other operations on lock objects
-- are undefined unless the lock object has been initialized
-- and has not since been finalized.
-- The effects of the other operations on lock objects are undefined
-- unless the lock object has been initialized and has not since been
-- finalized.
--
-- Initialization of the per-task lock is implicit in Create_Task.
--
@ -230,89 +226,82 @@ package System.Task_Primitives.Operations is
-- read or write permission. (That is, matching pairs of Lock and Unlock
-- operations on each lock object must be properly nested.)
-- For the operation on RTS_Lock, Global_Lock should be set to True
-- if L is a global lock (Single_RTS_Lock, Global_Task_Lock).
-- For the operation on RTS_Lock, Global_Lock should be set to True if L
-- is a global lock (Single_RTS_Lock, Global_Task_Lock).
--
-- Note that Write_Lock for RTS_Lock does not have an out-parameter.
-- RTS_Locks are used in situations where we have not made provision
-- for recovery from ceiling violations. We do not expect them to
-- occur inside the runtime system, because all RTS locks have ceiling
-- Priority'Last.
-- RTS_Locks are used in situations where we have not made provision for
-- recovery from ceiling violations. We do not expect them to occur inside
-- the runtime system, because all RTS locks have ceiling Priority'Last.
-- There is one way there can be a ceiling violation.
-- That is if the runtime system is called from a task that is
-- executing in the Interrupt_Priority range.
-- There is one way there can be a ceiling violation. That is if the
-- runtime system is called from a task that is executing in the
-- Interrupt_Priority range.
-- It is not clear what to do about ceiling violations due
-- to RTS calls done at interrupt priority. In general, it
-- is not acceptable to give all RTS locks interrupt priority,
-- since that whould give terrible performance on systems where
-- this has the effect of masking hardware interrupts, though we
-- could get away with allowing Interrupt_Priority'last where we
-- are layered on an OS that does not allow us to mask interrupts.
-- Ideally, we would like to raise Program_Error back at the
-- original point of the RTS call, but this would require a lot of
-- detailed analysis and recoding, with almost certain performance
-- penalties.
-- It is not clear what to do about ceiling violations due to RTS calls
-- done at interrupt priority. In general, it is not acceptable to give
-- all RTS locks interrupt priority, since that whould give terrible
-- performance on systems where this has the effect of masking hardware
-- interrupts, though we could get away with allowing
-- Interrupt_Priority'last where we are layered on an OS that does not
-- allow us to mask interrupts. Ideally, we would like to raise
-- Program_Error back at the original point of the RTS call, but this
-- would require a lot of detailed analysis and recoding, with almost
-- certain performance penalties.
-- For POSIX systems, we considered just skipping setting a
-- priority ceiling on RTS locks. This would mean there is no
-- ceiling violation, but we would end up with priority inversions
-- inside the runtime system, resulting in failure to satisfy the
-- Ada priority rules, and possible missed validation tests.
-- This could be compensated-for by explicit priority-change calls
-- to raise the caller to Priority'Last whenever it first enters
-- the runtime system, but the expected overhead seems high, though
-- it might be lower than using locks with ceilings if the underlying
-- implementation of ceiling locks is an inefficient one.
-- For POSIX systems, we considered just skipping setting priority ceiling
-- on RTS locks. This would mean there is no ceiling violation, but we
-- would end up with priority inversions inside the runtime system,
-- resulting in failure to satisfy the Ada priority rules, and possible
-- missed validation tests. This could be compensated-for by explicit
-- priority-change calls to raise the caller to Priority'Last whenever it
-- first enters the runtime system, but the expected overhead seems high,
-- though it might be lower than using locks with ceilings if the
-- underlying implementation of ceiling locks is an inefficient one.
-- This issue should be reconsidered whenever we get around to
-- checking for calls to potentially blocking operations from
-- within protected operations. If we check for such calls and
-- catch them on entry to the OS, it may be that we can eliminate
-- the possibility of ceiling violations inside the RTS. For this
-- to work, we would have to forbid explicitly setting the priority
-- of a task to anything in the Interrupt_Priority range, at least.
-- We would also have to check that there are no RTS-lock operations
-- done inside any operations that are not treated as potentially
-- blocking.
-- This issue should be reconsidered whenever we get around to checking
-- for calls to potentially blocking operations from within protected
-- operations. If we check for such calls and catch them on entry to the
-- OS, it may be that we can eliminate the possibility of ceiling
-- violations inside the RTS. For this to work, we would have to forbid
-- explicitly setting the priority of a task to anything in the
-- Interrupt_Priority range, at least. We would also have to check that
-- there are no RTS-lock operations done inside any operations that are
-- not treated as potentially blocking.
-- The latter approach seems to be the best, i.e. to check on entry
-- to RTS calls that may need to use locks that the priority is not
-- in the interrupt range. If there are RTS operations that NEED to
-- be called from interrupt handlers, those few RTS locks should then
-- be converted to PO-type locks, with ceiling Interrupt_Priority'Last.
-- The latter approach seems to be the best, i.e. to check on entry to RTS
-- calls that may need to use locks that the priority is not in the
-- interrupt range. If there are RTS operations that NEED to be called
-- from interrupt handlers, those few RTS locks should then be converted
-- to PO-type locks, with ceiling Interrupt_Priority'Last.
-- For now, we will just shut down the system if there is a
-- ceiling violation.
-- For now, we will just shut down the system if there is ceiling violation
procedure Yield (Do_Yield : Boolean := True);
pragma Inline (Yield);
-- Yield the processor. Add the calling task to the tail of the
-- ready queue for its active_priority.
-- The Do_Yield argument is only used in some very rare cases very
-- a yield should have an effect on a specific target and not on regular
-- ones.
-- Yield the processor. Add the calling task to the tail of the ready
-- queue for its active_priority. The Do_Yield argument is only used in
-- some very rare cases very a yield should have an effect on a specific
-- target and not on regular ones.
procedure Set_Priority
(T : ST.Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False);
pragma Inline (Set_Priority);
-- Set the priority of the task specified by T to T.Current_Priority.
-- The priority set is what would correspond to the Ada concept of
-- "base priority" in the terms of the lower layer system, but
-- the operation may be used by the upper layer to implement
-- changes in "active priority" that are not due to lock effects.
-- The effect should be consistent with the Ada Reference Manual.
-- In particular, when a task lowers its priority due to the loss of
-- inherited priority, it goes at the head of the queue for its new
-- priority (RM D.2.2 par 9). Loss_Of_Inheritance helps the underlying
-- implementation to do it right when the OS doesn't.
-- Set the priority of the task specified by T to T.Current_Priority. The
-- priority set is what would correspond to the Ada concept of "base
-- priority" in the terms of the lower layer system, but the operation may
-- be used by the upper layer to implement changes in "active priority"
-- that are not due to lock effects. The effect should be consistent with
-- the Ada Reference Manual. In particular, when a task lowers its
-- priority due to the loss of inherited priority, it goes at the head of
-- the queue for its new priority (RM D.2.2 par 9). Loss_Of_Inheritance
-- helps the underlying implementation to do it right when the OS doesn't.
function Get_Priority (T : ST.Task_Id) return System.Any_Priority;
pragma Inline (Get_Priority);
-- Returns the priority last set by Set_Priority for this task.
-- Returns the priority last set by Set_Priority for this task
function Monotonic_Clock return Duration;
pragma Inline (Monotonic_Clock);
@ -343,17 +332,16 @@ package System.Task_Primitives.Operations is
-- and has abort deferred
--
-- postcondition:
-- The calling task is holding its own ATCB lock
-- and has abort deferred.
-- The calling task is holding its own ATCB lock and has abort deferred.
-- The effect is to atomically unlock T's lock and wait, so that another
-- task that is able to lock T's lock can be assured that the wait has
-- actually commenced, and that a Wakeup operation will cause the waiting
-- task to become ready for execution once again. When Sleep returns,
-- the waiting task will again hold its own ATCB lock. The waiting task
-- may become ready for execution at any time (that is, spurious wakeups
-- are permitted), but it will definitely become ready for execution when
-- a Wakeup operation is performed for the same task.
-- task to become ready for execution once again. When Sleep returns, the
-- waiting task will again hold its own ATCB lock. The waiting task may
-- become ready for execution at any time (that is, spurious wakeups are
-- permitted), but it will definitely become ready for execution when a
-- Wakeup operation is performed for the same task.
procedure Timed_Sleep
(Self_ID : ST.Task_Id;
@ -399,21 +387,20 @@ package System.Task_Primitives.Operations is
-- RTS Entrance/Exit --
-----------------------
-- Following two routines are used for possible operations needed
-- to be setup/cleared upon entrance/exit of RTS while maintaining
-- a single thread of control in the RTS. Since we intend these
-- routines to be used for implementing the Single_Lock RTS,
-- Lock_RTS should follow the first Defer_Abortion operation
-- entering RTS. In the same fashion Unlock_RTS should preceed
-- the last Undefer_Abortion exiting RTS.
-- Following two routines are used for possible operations needed to be
-- setup/cleared upon entrance/exit of RTS while maintaining a single
-- thread of control in the RTS. Since we intend these routines to be used
-- for implementing the Single_Lock RTS, Lock_RTS should follow the first
-- Defer_Abortion operation entering RTS. In the same fashion Unlock_RTS
-- should preceed the last Undefer_Abortion exiting RTS.
--
-- These routines also replace the functions Lock/Unlock_All_Tasks_List
procedure Lock_RTS;
-- Take the global RTS lock.
-- Take the global RTS lock
procedure Unlock_RTS;
-- Release the global RTS lock.
-- Release the global RTS lock
--------------------
-- Stack Checking --
@ -424,30 +411,29 @@ package System.Task_Primitives.Operations is
-- an insufficient amount of stack space remains in the current task.
-- The exact mechanism for a stack probe is target dependent. Typical
-- possibilities are to use a load from a non-existent page, a store
-- to a read-only page, or a comparison with some stack limit constant.
-- Where possible we prefer to use a trap on a bad page access, since
-- this has less overhead. The generation of stack probes is either
-- automatic if the ABI requires it (as on for example DEC Unix), or
-- is controlled by the gcc parameter -fstack-check.
-- possibilities are to use a load from a non-existent page, a store to a
-- read-only page, or a comparison with some stack limit constant. Where
-- possible we prefer to use a trap on a bad page access, since this has
-- less overhead. The generation of stack probes is either automatic if
-- the ABI requires it (as on for example DEC Unix), or is controlled by
-- the gcc parameter -fstack-check.
-- When we are using bad-page accesses, we need a bad page, called a
-- guard page, at the end of each task stack. On some systems, this
-- is provided automatically, but on other systems, we need to create
-- the guard page ourselves, and the procedure Stack_Guard is provided
-- for this purpose.
-- When we are using bad-page accesses, we need a bad page, called guard
-- page, at the end of each task stack. On some systems, this is provided
-- automatically, but on other systems, we need to create the guard page
-- ourselves, and the procedure Stack_Guard is provided for this purpose.
procedure Stack_Guard (T : ST.Task_Id; On : Boolean);
-- Ensure guard page is set if one is needed and the underlying thread
-- system does not provide it. The procedure is as follows:
--
-- 1. When we create a task adjust its size so a guard page can
-- safely be set at the bottom of the stack
-- safely be set at the bottom of the stack.
--
-- 2. When the thread is created (and its stack allocated by the
-- underlying thread system), get the stack base (and size, depending
-- how the stack is growing), and create the guard page taking care of
-- page boundaries issues.
-- how the stack is growing), and create the guard page taking care
-- of page boundaries issues.
--
-- 3. When the task is destroyed, remove the guard page.
--
@ -467,11 +453,11 @@ package System.Task_Primitives.Operations is
function Check_Exit (Self_ID : ST.Task_Id) return Boolean;
pragma Inline (Check_Exit);
-- Check that the current task is holding only Global_Task_Lock.
-- Check that the current task is holding only Global_Task_Lock
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean;
pragma Inline (Check_No_Locks);
-- Check that current task is holding no locks.
-- Check that current task is holding no locks
function Suspend_Task
(T : ST.Task_Id;

70
gcc/ada/s-tasini.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -41,30 +41,30 @@ pragma Polling (Off);
-- to poll it can cause infinite loops.
with Ada.Exceptions;
-- used for Exception_Occurrence_Access.
-- Used for Exception_Occurrence_Access
with System.Tasking;
pragma Elaborate_All (System.Tasking);
-- ensure that the first step initializations have been performed
-- Ensure that the first step initializations have been performed
with System.Task_Primitives;
-- used for Lock
-- Used for Lock
with System.Task_Primitives.Operations;
-- used for Set_Priority
-- Used for Set_Priority
-- Write_Lock
-- Unlock
-- Initialize_Lock
with System.Soft_Links;
-- used for the non-tasking routines (*_NT) that refer to global data.
-- Used for the non-tasking routines (*_NT) that refer to global data.
-- They are needed here before the tasking run time has been elaborated.
with System.Soft_Links.Tasking;
-- Used for Init_Tasking_Soft_Links
with System.Tasking.Debug;
-- used for Trace
-- Used for Trace
with System.Stack_Checking;
@ -88,7 +88,7 @@ package body System.Tasking.Initialization is
function Current_Target_Exception return AE.Exception_Occurrence;
pragma Import
(Ada, Current_Target_Exception, "__gnat_current_target_exception");
-- Import this subprogram from the private part of Ada.Exceptions.
-- Import this subprogram from the private part of Ada.Exceptions
----------------------------------------------------------------------
-- Tasking versions of some services needed by non-tasking programs --
@ -150,7 +150,7 @@ package body System.Tasking.Initialization is
-- Change_Base_Priority --
--------------------------
-- Call only with abort deferred and holding Self_ID locked.
-- Call only with abort deferred and holding Self_ID locked
procedure Change_Base_Priority (T : Task_Id) is
begin
@ -269,7 +269,7 @@ package body System.Tasking.Initialization is
-- while we had abort deferred below.
loop
-- Temporarily defer abortion so that we can lock Self_ID.
-- Temporarily defer abort so that we can lock Self_ID
Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1;
@ -286,7 +286,7 @@ package body System.Tasking.Initialization is
Unlock_RTS;
end if;
-- Restore the original Deferral value.
-- Restore the original Deferral value
Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1;
@ -401,11 +401,11 @@ package body System.Tasking.Initialization is
SSL.Tasking.Init_Tasking_Soft_Links;
-- Install tasking locks in the GCC runtime.
-- Install tasking locks in the GCC runtime
Gnat_Install_Locks (Task_Lock'Access, Task_Unlock'Access);
-- Abortion is deferred in a new ATCB, so we need to undefer abortion
-- Abort is deferred in a new ATCB, so we need to undefer abort
-- at this stage to make the environment task abortable.
Undefer_Abort (Environment_Task);
@ -426,15 +426,16 @@ package body System.Tasking.Initialization is
-- hurt to uncomment the above call, until the error is corrected for
-- all targets.
-- See extended comments in package body System.Tasking.Abortion
-- for the overall design of the implementation of task abort.
-- See extended comments in package body System.Tasking.Abort for the
-- overall design of the implementation of task abort.
-- ??? there is no such package ???
-- If the task is sleeping it will be in an abort-deferred region,
-- and will not have Abort_Signal raised by Abort_Task.
-- Such an "abort deferral" is just to protect the RTS internals,
-- and not necessarily required to enforce Ada semantics.
-- Abort_Task should wake the task up and let it decide if it wants
-- to complete the aborted construct immediately.
-- If the task is sleeping it will be in an abort-deferred region, and
-- will not have Abort_Signal raised by Abort_Task. Such an "abort
-- deferral" is just to protect the RTS internals, and not necessarily
-- required to enforce Ada semantics. Abort_Task should wake the task up
-- and let it decide if it wants to complete the aborted construct
-- immediately.
-- Note that the effect of the lowl-level Abort_Task is not persistent.
-- If the target task is not blocked, this wakeup will be missed.
@ -452,14 +453,13 @@ package body System.Tasking.Initialization is
-- implement delays). That still left the possibility of missed
-- wakeups.
-- We cannot safely call Vulnerable_Complete_Activation here,
-- since that requires locking Self_ID.Parent. The anti-deadlock
-- lock ordering rules would then require us to release the lock
-- on Self_ID first, which would create a timing window for other
-- tasks to lock Self_ID. This is significant for tasks that may be
-- aborted before their execution can enter the task body, and so
-- they do not get a chance to call Complete_Task. The actual work
-- for this case is done in Terminate_Task.
-- We cannot safely call Vulnerable_Complete_Activation here, since that
-- requires locking Self_ID.Parent. The anti-deadlock lock ordering rules
-- would then require us to release the lock on Self_ID first, which would
-- create a timing window for other tasks to lock Self_ID. This is
-- significant for tasks that may be aborted before their execution can
-- enter the task body, and so they do not get a chance to call
-- Complete_Task. The actual work for this case is done in Terminate_Task.
procedure Locked_Abort_To_Level
(Self_ID : Task_Id;
@ -694,12 +694,12 @@ package body System.Tasking.Initialization is
-- Precondition : Self does not hold any locks!
-- Undefer_Abort is called on any abortion completion point (aka.
-- Undefer_Abort is called on any abort completion point (aka.
-- synchronization point). It performs the following actions if they
-- are pending: (1) change the base priority, (2) abort the task.
-- The priority change has to occur before abortion. Otherwise, it would
-- take effect no earlier than the next abortion completion point.
-- The priority change has to occur before abort. Otherwise, it would
-- take effect no earlier than the next abort completion point.
procedure Undefer_Abort (Self_ID : Task_Id) is
begin
@ -761,8 +761,8 @@ package body System.Tasking.Initialization is
-- Undefer_Abortion --
----------------------
-- Phase out RTS-internal use of Undefer_Abortion
-- to reduce overhead due to multiple calls to Self.
-- Phase out RTS-internal use of Undefer_Abortion to reduce overhead due
-- to multiple calls to Self.
procedure Undefer_Abortion is
Self_ID : Task_Id;
@ -806,7 +806,7 @@ package body System.Tasking.Initialization is
-- Update_Exception --
----------------------
-- Call only when holding no locks.
-- Call only when holding no locks
procedure Update_Exception
(X : AE.Exception_Occurrence := Current_Target_Exception)

110
gcc/ada/s-tasini.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -37,8 +37,7 @@
package System.Tasking.Initialization is
procedure Remove_From_All_Tasks_List (T : Task_Id);
-- Remove T from All_Tasks_List.
-- Call this function with RTS_Lock taken.
-- Remove T from All_Tasks_List. Call this function with RTS_Lock taken
---------------------------------
-- Tasking-Specific Soft Links --
@ -47,7 +46,8 @@ package System.Tasking.Initialization is
-- These permit us to leave out certain portions of the tasking
-- run-time system if they are not used. They are only used internally
-- by the tasking run-time system.
-- So far, the only example is support for Ada.Task_Attributes.
-- So far, the only example is support for Ada.Task_Attributes
type Proc_T is access procedure (T : Task_Id);
@ -55,10 +55,10 @@ package System.Tasking.Initialization is
procedure Initialize_Attributes (T : Task_Id);
Finalize_Attributes_Link : Proc_T := Finalize_Attributes'Access;
-- should be called with abortion deferred and T.L write-locked
-- should be called with abort deferred and T.L write-locked
Initialize_Attributes_Link : Proc_T := Initialize_Attributes'Access;
-- should be called with abortion deferred, but holding no locks
-- should be called with abort deferred, but holding no locks
-------------------------
-- Abort Defer/Undefer --
@ -75,36 +75,34 @@ package System.Tasking.Initialization is
-- 2) abort/ATC
-- Abort deferral MAY be nested (Self_ID.Deferral_Level is a count),
-- but to avoid waste and undetected errors, it generally SHOULD NOT
-- be nested. The symptom of over-deferring abort is that an exception
-- may fail to be raised, or an abort may fail to take place.
-- Abort deferral MAY be nested (Self_ID.Deferral_Level is a count), but
-- to avoid waste and undetected errors, it generally SHOULD NOT be
-- nested. The symptom of over-deferring abort is that an exception may
-- fail to be raised, or an abort may fail to take place.
-- Therefore, there are two sets of the inlinable defer/undefer
-- routines, which are the ones to be used inside GNARL.
-- One set allows nesting. The other does not. People who
-- maintain the GNARL should try to avoid using the nested versions,
-- or at least look very critically at the places where they are
-- used.
-- Therefore, there are two sets of the inlinable defer/undefer routines,
-- which are the ones to be used inside GNARL. One set allows nesting. The
-- other does not. People who maintain the GNARL should try to avoid using
-- the nested versions, or at least look very critically at the places
-- where they are used.
-- In general, any GNARL call that is potentially blocking, or
-- whose semantics require that it sometimes raise an exception,
-- or that is required to be an abort completion point, must be
-- made with abort Deferral_Level = 1.
-- In general, any GNARL call that is potentially blocking, or whose
-- semantics require that it sometimes raise an exception, or that is
-- required to be an abort completion point, must be made with abort
-- Deferral_Level = 1.
-- In general, non-blocking GNARL calls, which may be made from inside
-- a protected action, are likely to need to allow nested abort
-- deferral.
-- In general, non-blocking GNARL calls, which may be made from inside a
-- protected action, are likely to need to allow nested abort deferral.
-- With some critical exceptions (which are supposed to be documented),
-- internal calls to the tasking runtime system assume abort is already
-- deferred, and do not modify the deferral level.
-- There is also a set of non-linable defer/undefer routines,
-- for direct call from the compiler. These are not in-lineable
-- because they may need to be called via pointers ("soft links").
-- For the sake of efficiency, the version with Self_ID as parameter
-- should used wherever possible. These are all nestable.
-- There is also a set of non-linable defer/undefer routines, for direct
-- call from the compiler. These are not in-lineable because they may need
-- to be called via pointers ("soft links"). For the sake of efficiency,
-- the version with Self_ID as parameter should used wherever possible.
-- These are all nestable.
-- Non-nestable inline versions
@ -128,16 +126,14 @@ package System.Tasking.Initialization is
procedure Defer_Abortion;
procedure Undefer_Abortion;
-- ?????
-- Try to phase out all uses of the above versions.
-- Try to phase out all uses of the above versions ???
procedure Do_Pending_Action (Self_ID : Task_Id);
-- Only call with no locks, and when Self_ID.Pending_Action = True
-- Perform necessary pending actions (e.g. abortion, priority change).
-- This procedure is usually called when needed as a result of
-- calling Undefer_Abort, although in the case of e.g. No_Abort
-- restriction, it can be necessary to force execution of pending
-- actions.
-- Only call with no locks, and when Self_ID.Pending_Action = True Perform
-- necessary pending actions (e.g. abort, priority change). This procedure
-- is usually called when needed as a result of calling Undefer_Abort,
-- although in the case of e.g. No_Abort restriction, it can be necessary
-- to force execution of pending actions.
function Check_Abort_Status return Integer;
-- Returns Boolean'Pos (True) iff abort signal should raise
@ -148,9 +144,8 @@ package System.Tasking.Initialization is
--------------------------
procedure Change_Base_Priority (T : Task_Id);
-- Change the base priority of T.
-- Has to be called with the affected task's ATCB write-locked.
-- May temporariliy release the lock.
-- Change the base priority of T. Has to be called with the affected
-- task's ATCB write-locked. May temporariliy release the lock.
procedure Poll_Base_Priority_Change (Self_ID : Task_Id);
-- Has to be called with Self_ID's ATCB write-locked.
@ -170,44 +165,41 @@ package System.Tasking.Initialization is
-- within the GNARL.
procedure Final_Task_Unlock (Self_ID : Task_Id);
-- This version is only for use in Terminate_Task, when the task
-- is relinquishing further rights to its own ATCB.
-- There is a very interesting potential race condition there, where
-- the old task may run concurrently with a new task that is allocated
-- the old tasks (now reused) ATCB. The critical thing here is to
-- not make any reference to the ATCB after the lock is released.
-- See also comments on Terminate_Task and Unlock.
-- This version is only for use in Terminate_Task, when the task is
-- relinquishing further rights to its own ATCB. There is a very
-- interesting potential race condition there, where the old task may run
-- concurrently with a new task that is allocated the old tasks (now
-- reused) ATCB. The critical thing here is to not make any reference to
-- the ATCB after the lock is released. See also comments on
-- Terminate_Task and Unlock.
procedure Wakeup_Entry_Caller
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link;
New_State : Entry_Call_State);
pragma Inline (Wakeup_Entry_Caller);
-- This is called at the end of service of an entry call,
-- to abort the caller if he is in an abortable part, and
-- to wake up the caller if he is on Entry_Caller_Sleep.
-- Call it holding the lock of Entry_Call.Self.
-- This is called at the end of service of an entry call, to abort the
-- caller if he is in an abortable part, and to wake up the caller if he
-- is on Entry_Caller_Sleep. Call it holding the lock of Entry_Call.Self.
--
-- Timed_Call or Simple_Call:
-- The caller is waiting on Entry_Caller_Sleep, in
-- Wait_For_Completion, or Wait_For_Completion_With_Timeout.
-- The caller is waiting on Entry_Caller_Sleep, in Wait_For_Completion,
-- or Wait_For_Completion_With_Timeout.
--
-- Conditional_Call:
-- The caller might be in Wait_For_Completion,
-- waiting for a rendezvous (possibly requeued without abort)
-- to complete.
-- waiting for a rendezvous (possibly requeued without abort) to
-- complete.
--
-- Asynchronous_Call:
-- The caller may be executing in the abortable part o
-- an async. select, or on a time delay,
-- if Entry_Call.State >= Was_Abortable.
-- The caller may be executing in the abortable part an async. select,
-- or on a time delay, if Entry_Call.State >= Was_Abortable.
procedure Locked_Abort_To_Level
(Self_ID : Task_Id;
T : Task_Id;
L : ATC_Level);
pragma Inline (Locked_Abort_To_Level);
-- Abort a task to a specified ATC level.
-- Call this only with T locked.
-- Abort a task to a specified ATC level. Call this only with T locked
end System.Tasking.Initialization;

419
gcc/ada/s-taskin.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -31,7 +31,7 @@
-- --
------------------------------------------------------------------------------
-- This package provides necessary type definitions for compiler interface.
-- This package provides necessary type definitions for compiler interface
-- Note: the compiler generates direct calls to this interface, via Rtsfind.
-- Any changes to this interface may require corresponding compiler changes.
@ -62,13 +62,12 @@ package System.Tasking is
-- The following rules must be followed at all times, to prevent
-- deadlock and generally ensure correct operation of locking.
-- . Never lock a lock unless abort is deferred.
-- Never lock a lock unless abort is deferred
-- . Never undefer abort while holding a lock.
-- Never undefer abort while holding a lock
-- . Overlapping critical sections must be properly nested,
-- and locks must be released in LIFO order.
-- e.g., the following is not allowed:
-- Overlapping critical sections must be properly nested, and locks must
-- be released in LIFO order. e.g., the following is not allowed:
-- Lock (X);
-- ...
@ -80,7 +79,6 @@ package System.Tasking is
-- Locks with lower (smaller) level number cannot be locked
-- while holding a lock with a higher level number. (The level
-- number is the number at the left.)
-- 1. System.Tasking.PO_Simple.Protection.L (any PO lock)
-- 2. System.Tasking.Initialization.Global_Task_Lock (in body)
@ -94,13 +92,13 @@ package System.Tasking is
-- clearly wrong since there can be calls to "new" inside protected
-- operations. The new ordering prevents these failures.
-- Sometimes we need to hold two ATCB locks at the same time. To allow
-- us to order the locking, each ATCB is given a unique serial
-- number. If one needs to hold locks on several ATCBs at once,
-- the locks with lower serial numbers must be locked first.
-- Sometimes we need to hold two ATCB locks at the same time. To allow us
-- to order the locking, each ATCB is given a unique serial number. If one
-- needs to hold locks on several ATCBs at once, the locks with lower
-- serial numbers must be locked first.
-- We don't always need to check the serial numbers, since
-- the serial numbers are assigned sequentially, and so:
-- We don't always need to check the serial numbers, since the serial
-- numbers are assigned sequentially, and so:
-- . The parent of a task always has a lower serial number.
-- . The activator of a task always has a lower serial number.
@ -157,13 +155,13 @@ package System.Tasking is
-- alternatives have been awakened and have terminated themselves.
Activator_Sleep,
-- Task is waiting for created tasks to complete activation.
-- Task is waiting for created tasks to complete activation
Acceptor_Sleep,
-- Task is waiting on an accept or selective wait statement.
-- Task is waiting on an accept or selective wait statement
Entry_Caller_Sleep,
-- Task is waiting on an entry call.
-- Task is waiting on an entry call
Async_Select_Sleep,
-- Task is waiting to start the abortable part of an
@ -309,20 +307,20 @@ package System.Tasking is
State : Entry_Call_State;
pragma Atomic (State);
-- Indicates part of the state of the call.
-- Protection:
-- If the call is not on a queue, it should
-- only be accessed by Self, and Self does not need any
-- lock to modify this field.
-- Once the call is on a queue, the value should be
-- something other than Done unless it is cancelled, and access is
-- controller by the "server" of the queue -- i.e., the lock
-- of Checked_To_Protection (Call_Target)
-- if the call record is on the queue of a PO, or the lock
-- of Called_Target if the call is on the queue of a task.
-- See comments on type declaration for more details.
--
-- Protection: If the call is not on a queue, it should only be
-- accessed by Self, and Self does not need any lock to modify this
-- field.
--
-- Once the call is on a queue, the value should be something other
-- than Done unless it is cancelled, and access is controller by the
-- "server" of the queue -- i.e., the lock of Checked_To_Protection
-- (Call_Target) if the call record is on the queue of a PO, or the
-- lock of Called_Target if the call is on the queue of a task. See
-- comments on type declaration for more details.
Uninterpreted_Data : System.Address;
-- Data passed by the compiler.
-- Data passed by the compiler
Exception_To_Raise : Ada.Exceptions.Exception_Id;
-- The exception to raise once this call has been completed without
@ -351,7 +349,7 @@ package System.Tasking is
-- Ada_Task_Control_Block (ATCB) definition --
----------------------------------------------
-- Notes on protection (synchronization) of TRTS data structures.
-- Notes on protection (synchronization) of TRTS data structures
-- Any field of the TCB can be written by the activator of a task when the
-- task is created, since no other task can access the new task's
@ -360,7 +358,7 @@ package System.Tasking is
-- The protection for each field is described in a comment starting with
-- "Protection:".
-- When a lock is used to protect an ATCB field, this lock is simply named.
-- When a lock is used to protect an ATCB field, this lock is simply named
-- Some protection is described in terms of tasks related to the
-- ATCB being protected. These are:
@ -390,7 +388,8 @@ package System.Tasking is
-- Encodes some basic information about the state of a task,
-- including whether it has been activated, whether it is sleeping,
-- and whether it is terminated.
-- Protection: Self.L.
--
-- Protection: Self.L
Parent : Task_Id;
-- The task on which this task depends.
@ -399,7 +398,8 @@ package System.Tasking is
Base_Priority : System.Any_Priority;
-- Base priority, not changed during entry calls, only changed
-- via dynamic priorities package.
-- Protection: Only written by Self, accessed by anyone.
--
-- Protection: Only written by Self, accessed by anyone
Current_Priority : System.Any_Priority;
-- Active priority, except that the effects of protected object
@ -428,96 +428,104 @@ package System.Tasking is
Protected_Action_Nesting : Natural;
pragma Atomic (Protected_Action_Nesting);
-- The dynamic level of protected action nesting for this task.
-- This field is needed for checking whether potentially
-- blocking operations are invoked from protected actions.
-- pragma Atomic is used because it can be read/written from
-- protected interrupt handlers.
-- The dynamic level of protected action nesting for this task. This
-- field is needed for checking whether potentially blocking operations
-- are invoked from protected actions. pragma Atomic is used because it
-- can be read/written from protected interrupt handlers.
Task_Image : String (1 .. 32);
-- Hold a string that provides a readable id for task,
-- built from the variable of which it is a value or component.
Task_Image_Len : Natural;
-- Actual length of Task_Image.
-- Actual length of Task_Image
Call : Entry_Call_Link;
-- The entry call that has been accepted by this task.
-- Protection: Self.L. Self will modify this field
-- when Self.Accepting is False, and will not need the mutex to do so.
-- Once a task sets Pending_ATC_Level = 0, no other task can access
-- this field.
--
-- Protection: Self.L. Self will modify this field when Self.Accepting
-- is False, and will not need the mutex to do so. Once a task sets
-- Pending_ATC_Level = 0, no other task can access this field.
LL : aliased Task_Primitives.Private_Data;
-- Control block used by the underlying low-level tasking
-- service (GNULLI).
-- Control block used by the underlying low-level tasking service
-- (GNULLI).
--
-- Protection: This is used only by the GNULLI implementation, which
-- takes care of all of its synchronization.
Task_Arg : System.Address;
-- The argument to task procedure. Provide a handle for discriminant
-- information.
-- Protection: Part of the synchronization between Self and
-- Activator. Activator writes it, once, before Self starts
-- executing. Thereafter, Self only reads it.
-- information
--
-- Protection: Part of the synchronization between Self and Activator.
-- Activator writes it, once, before Self starts executing. Thereafter,
-- Self only reads it.
Task_Entry_Point : Task_Procedure_Access;
-- Information needed to call the procedure containing the code for
-- the body of this task.
-- Protection: Part of the synchronization between Self and
-- Activator. Activator writes it, once, before Self starts
-- executing. Self reads it, once, as part of its execution.
--
-- Protection: Part of the synchronization between Self and Activator.
-- Activator writes it, once, before Self starts executing. Self reads
-- it, once, as part of its execution.
Compiler_Data : System.Soft_Links.TSD;
-- Task-specific data needed by the compiler to store
-- per-task structures.
-- Protection: Only accessed by Self.
-- Task-specific data needed by the compiler to store per-task
-- structures.
--
-- Protection: Only accessed by Self
All_Tasks_Link : Task_Id;
-- Used to link this task to the list of all tasks in the system.
-- Protection: RTS_Lock.
-- Used to link this task to the list of all tasks in the system
--
-- Protection: RTS_Lock
Activation_Link : Task_Id;
-- Used to link this task to a list of tasks to be activated.
-- Protection: Only used by Activator.
-- Used to link this task to a list of tasks to be activated
--
-- Protection: Only used by Activator
Activator : Task_Id;
-- The task that created this task, either by declaring it as a task
-- object or by executing a task allocator.
-- The value is null iff Self has completed activation.
-- Protection: Set by Activator before Self is activated, and
-- only read and modified by Self after that.
-- object or by executing a task allocator. The value is null iff Self
-- has completed activation.
--
-- Protection: Set by Activator before Self is activated, and only read
-- and modified by Self after that.
Wait_Count : Integer;
-- This count is used by a task that is waiting for other tasks.
-- At all other times, the value should be zero.
-- It is used differently in several different states.
-- Since a task cannot be in more than one of these states at the
-- same time, a single counter suffices.
-- Protection: Self.L.
-- This count is used by a task that is waiting for other tasks. At all
-- other times, the value should be zero. It is used differently in
-- several different states. Since a task cannot be in more than one of
-- these states at the same time, a single counter suffices.
--
-- Protection: Self.L
-- Activator_Sleep
-- This is the number of tasks that this task is activating, i.e. the
-- children that have started activation but have not completed it.
-- Protection: Self.L and Created.L. Both mutexes must be locked,
-- since Self.Activation_Count and Created.State must be synchronized.
--
-- Protection: Self.L and Created.L. Both mutexes must be locked, since
-- Self.Activation_Count and Created.State must be synchronized.
-- Master_Completion_Sleep (phase 1)
-- This is the number dependent tasks of a master being
-- completed by Self that are not activated, not terminated, and
-- not waiting on a terminate alternative.
-- This is the number dependent tasks of a master being completed by
-- Self that are not activated, not terminated, and not waiting on a
-- terminate alternative.
-- Master_Completion_2_Sleep (phase 2)
-- This is the count of tasks dependent on a master being
-- completed by Self which are waiting on a terminate alternative.
-- This is the count of tasks dependent on a master being completed by
-- Self which are waiting on a terminate alternative.
Elaborated : Access_Boolean;
-- Pointer to a flag indicating that this task's body has been
-- elaborated. The flag is created and managed by the
-- compiler-generated code.
--
-- Protection: The field itself is only accessed by Activator. The flag
-- that it points to is updated by Master and read by Activator; access
-- is assumed to be atomic.
@ -539,6 +547,7 @@ package System.Tasking is
-- restricted GNULL implementations to allocate an ATCB (see
-- System.Task_Primitives.Operations.New_ATCB) that will take
-- significantly less memory.
-- Note that the restricted GNARLI should only access fields that are
-- present in the Restricted_Ada_Task_Control_Block structure.
@ -564,7 +573,7 @@ package System.Tasking is
-----------------------
All_Tasks_List : Task_Id;
-- Global linked list of all tasks.
-- Global linked list of all tasks
------------------------------------------
-- Regular (non restricted) definitions --
@ -577,13 +586,13 @@ package System.Tasking is
subtype Master_Level is Integer;
subtype Master_ID is Master_Level;
-- Normally, a task starts out with internal master nesting level
-- one larger than external master nesting level. It is incremented
-- to one by Enter_Master, which is called in the task body only if
-- the compiler thinks the task may have dependent tasks. It is set to 1
-- for the environment task, the level 2 is reserved for server tasks of
-- the run-time system (the so called "independent tasks"), and the level
-- 3 is for the library level tasks.
-- Normally, a task starts out with internal master nesting level one
-- larger than external master nesting level. It is incremented to one by
-- Enter_Master, which is called in the task body only if the compiler
-- thinks the task may have dependent tasks. It is set to for the
-- environment task, the level 2 is reserved for server tasks of the
-- run-time system (the so called "independent tasks"), and the level 3 is
-- for the library level tasks.
Environment_Task_Level : constant Master_Level := 1;
Independent_Task_Level : constant Master_Level := 2;
@ -596,7 +605,7 @@ package System.Tasking is
Unspecified_Priority : constant Integer := System.Priority'First - 1;
Priority_Not_Boosted : constant Integer := System.Priority'First - 1;
-- Definition of Priority actually has to come from the RTS configuration.
-- Definition of Priority actually has to come from the RTS configuration
subtype Rendezvous_Priority is Integer
range Priority_Not_Boosted .. System.Any_Priority'Last;
@ -652,21 +661,19 @@ package System.Tasking is
State : Entry_Call_State;
pragma Atomic (State);
-- Indicates part of the state of the call.
-- Protection:
-- If the call is not on a queue, it should
-- only be accessed by Self, and Self does not need any
-- lock to modify this field.
-- Once the call is on a queue, the value should be
-- something other than Done unless it is cancelled, and access is
-- controller by the "server" of the queue -- i.e., the lock
-- of Checked_To_Protection (Call_Target)
-- if the call record is on the queue of a PO, or the lock
-- of Called_Target if the call is on the queue of a task.
-- See comments on type declaration for more details.
-- Indicates part of the state of the call
--
-- Protection: If the call is not on a queue, it should only be
-- accessed by Self, and Self does not need any lock to modify this
-- field. Once the call is on a queue, the value should be something
-- other than Done unless it is cancelled, and access is controller by
-- the "server" of the queue -- i.e., the lock of Checked_To_Protection
-- (Call_Target) if the call record is on the queue of a PO, or the
-- lock of Called_Target if the call is on the queue of a task. See
-- comments on type declaration for more details.
Uninterpreted_Data : System.Address;
-- Data passed by the compiler.
-- Data passed by the compiler
Exception_To_Raise : Ada.Exceptions.Exception_Id;
-- The exception to raise once this call has been completed without
@ -693,42 +700,39 @@ package System.Tasking is
Called_Task : Task_Id;
pragma Atomic (Called_Task);
-- Use for task entry calls.
-- The value is null if the call record is not in use.
-- Conversely, unless State is Done and Onqueue is false,
-- Use for task entry calls. The value is null if the call record is
-- not in use. Conversely, unless State is Done and Onqueue is false,
-- Called_Task points to an ATCB.
-- Protection: Called_Task.L.
--
-- Protection: Called_Task.L
Called_PO : System.Address;
pragma Atomic (Called_PO);
-- Similar to Called_Task but for protected objects.
-- Similar to Called_Task but for protected objects
--
-- Note that the previous implementation tried to merge both
-- Called_Task and Called_PO but this ended up in many unexpected
-- complications (e.g having to add a magic number in the ATCB, which
-- caused gdb lots of confusion) with no real gain since the Lock_Server
-- implementation still need to loop around chasing for pointer changes
-- even with a single pointer.
-- caused gdb lots of confusion) with no real gain since the
-- Lock_Server implementation still need to loop around chasing for
-- pointer changes even with a single pointer.
Acceptor_Prev_Call : Entry_Call_Link;
-- For task entry calls only.
-- For task entry calls only
Acceptor_Prev_Priority : Rendezvous_Priority := Priority_Not_Boosted;
-- For task entry calls only.
-- The priority of the most recent prior call being serviced.
-- For protected entry calls, this function should be performed by
-- GNULLI ceiling locking.
-- For task entry calls only. The priority of the most recent prior
-- call being serviced. For protected entry calls, this function should
-- be performed by GNULLI ceiling locking.
Cancellation_Attempted : Boolean := False;
pragma Atomic (Cancellation_Attempted);
-- Cancellation of the call has been attempted.
-- If it has succeeded, State = Cancelled.
-- ?????
-- Consider merging this into State?
-- Consider merging this into State???
Requeue_With_Abort : Boolean := False;
-- Temporary to tell caller whether requeue is with abort.
-- ?????
-- Find a better way of doing this.
-- Find a better way of doing this ???
Needs_Requeue : Boolean := False;
-- Temporary to tell acceptor of task entry call that
@ -756,10 +760,10 @@ package System.Tasking is
type Direct_Index is range 0 .. Parameters.Default_Attribute_Count;
subtype Direct_Index_Range is Direct_Index range 1 .. Direct_Index'Last;
-- Attributes with indices in this range are stored directly in
-- the task control block. Such attributes must be Address-sized.
-- Other attributes will be held in dynamically allocated records
-- chained off of the task control block.
-- Attributes with indices in this range are stored directly in the task
-- control block. Such attributes must be Address-sized. Other attributes
-- will be held in dynamically allocated records chained off of the task
-- control block.
type Direct_Attribute_Element is mod Memory_Size;
pragma Atomic (Direct_Attribute_Element);
@ -772,86 +776,95 @@ package System.Tasking is
-- the usage of the direct attribute fields.
type Task_Serial_Number is mod 2 ** 64;
-- Used to give each task a unique serial number.
-- Used to give each task a unique serial number
type Ada_Task_Control_Block (Entry_Num : Task_Entry_Index) is record
Common : Common_ATCB;
-- The common part between various tasking implementations
Entry_Calls : Entry_Call_Array;
-- An array of entry calls.
-- An array of entry calls
--
-- Protection: The elements of this array are on entry call queues
-- associated with protected objects or task entries, and are protected
-- by the protected object lock or Acceptor.L, respectively.
New_Base_Priority : System.Any_Priority;
-- New value for Base_Priority (for dynamic priorities package).
-- Protection: Self.L.
-- New value for Base_Priority (for dynamic priorities package)
--
-- Protection: Self.L
Global_Task_Lock_Nesting : Natural := 0;
-- This is the current nesting level of calls to
-- System.Tasking.Stages.Lock_Task_T.
-- This allows a task to call Lock_Task_T multiple times without
-- deadlocking. A task only locks All_Task_Lock when its
-- All_Tasks_Nesting goes from 0 to 1, and only unlocked when it
-- goes from 1 to 0.
-- Protection: Only accessed by Self.
-- System.Tasking.Stages.Lock_Task_T. This allows a task to call
-- Lock_Task_T multiple times without deadlocking. A task only locks
-- All_Task_Lock when its All_Tasks_Nesting goes from 0 to 1, and only
-- unlocked when it goes from 1 to 0.
--
-- Protection: Only accessed by Self
Open_Accepts : Accept_List_Access;
-- This points to the Open_Accepts array of accept alternatives passed
-- to the RTS by the compiler-generated code to Selective_Wait.
-- It is non-null iff this task is ready to accept an entry call.
-- Protection: Self.L.
-- to the RTS by the compiler-generated code to Selective_Wait. It is
-- non-null iff this task is ready to accept an entry call.
--
-- Protection: Self.L
Chosen_Index : Select_Index;
-- The index in Open_Accepts of the entry call accepted by a selective
-- wait executed by this task.
-- Protection: Written by both Self and Caller. Usually protected
-- by Self.L. However, once the selection is known to have been
-- written it can be accessed without protection. This happens
-- after Self has updated it itself using information from a suspended
-- Caller, or after Caller has updated it and awakened Self.
--
-- Protection: Written by both Self and Caller. Usually protected by
-- Self.L. However, once the selection is known to have been written it
-- can be accessed without protection. This happens after Self has
-- updated it itself using information from a suspended Caller, or
-- after Caller has updated it and awakened Self.
Master_of_Task : Master_Level;
-- The task executing the master of this task, and the ID of this task's
-- master (unique only among masters currently active within Parent).
-- Protection: Set by Activator before Self is activated, and
-- read after Self is activated.
--
-- Protection: Set by Activator before Self is activated, and read
-- after Self is activated.
Master_Within : Master_Level;
-- The ID of the master currently executing within this task; that is,
-- the most deeply nested currently active master.
--
-- Protection: Only written by Self, and only read by Self or by
-- dependents when Self is attempting to exit a master. Since Self
-- will not write this field until the master is complete, the
-- dependents when Self is attempting to exit a master. Since Self will
-- not write this field until the master is complete, the
-- synchronization should be adequate to prevent races.
Alive_Count : Integer := 0;
-- Number of tasks directly dependent on this task (including itself)
-- that are still "alive", i.e. not terminated.
-- Protection: Self.L.
--
-- Protection: Self.L
Awake_Count : Integer := 0;
-- Number of tasks directly dependent on this task (including itself)
-- still "awake", i.e., are not terminated and not waiting on a
-- terminate alternative.
--
-- Invariant: Awake_Count <= Alive_Count
-- Protection: Self.L.
-- beginning of flags
-- Protection: Self.L
-- Beginning of flags
Aborting : Boolean := False;
pragma Atomic (Aborting);
-- Self is in the process of aborting. While set, prevents multiple
-- abortion signals from being sent by different aborter while abortion
-- abort signals from being sent by different aborter while abort
-- is acted upon. This is essential since an aborter which calls
-- Abort_To_Level could set the Pending_ATC_Level to yet a lower level
-- (than the current level), may be preempted and would send the
-- abortion signal when resuming execution. At this point, the abortee
-- may have completed abortion to the proper level such that the
-- signal (and resulting abortion exception) are not handled any more.
-- abort signal when resuming execution. At this point, the abortee
-- may have completed abort to the proper level such that the
-- signal (and resulting abort exception) are not handled any more.
-- In other words, the flag prevents a race between multiple aborters
-- and the abortee.
--
-- Protection: protected by atomic access.
ATC_Hack : Boolean := False;
@ -863,17 +876,17 @@ package System.Tasking is
-- handler itself.
Callable : Boolean := True;
-- It is OK to call entries of this task.
-- It is OK to call entries of this task
Dependents_Aborted : Boolean := False;
-- This is set to True by whichever task takes responsibility
-- for aborting the dependents of this task.
-- Protection: Self.L.
-- This is set to True by whichever task takes responsibility for
-- aborting the dependents of this task.
--
-- Protection: Self.L
Interrupt_Entry : Boolean := False;
-- Indicates if one or more Interrupt Entries are attached to
-- the task. This flag is needed for cleaning up the Interrupt
-- Entry bindings.
-- Indicates if one or more Interrupt Entries are attached to the task.
-- This flag is needed for cleaning up the Interrupt Entry bindings.
Pending_Action : Boolean := False;
-- Unified flag indicating some action needs to be take when abort
@ -884,65 +897,68 @@ package System.Tasking is
-- (Abortable field may have changed and the Wait_Until_Abortable
-- has to recheck the abortable status of the call.)
-- . Exception_To_Raise is non-null
-- Protection: Self.L.
-- This should never be reset back to False outside of the
-- procedure Do_Pending_Action, which is called by Undefer_Abort.
-- It should only be set to True by Set_Priority and Abort_To_Level.
--
-- Protection: Self.L
--
-- This should never be reset back to False outside of the procedure
-- Do_Pending_Action, which is called by Undefer_Abort. It should only
-- be set to True by Set_Priority and Abort_To_Level.
Pending_Priority_Change : Boolean := False;
-- Flag to indicate pending priority change (for dynamic priorities
-- package). The base priority is updated on the next abortion
-- package). The base priority is updated on the next abort
-- completion point (aka. synchronization point).
-- Protection: Self.L.
--
-- Protection: Self.L
Terminate_Alternative : Boolean := False;
-- Task is accepting Select with Terminate Alternative.
-- Protection: Self.L.
-- Task is accepting Select with Terminate Alternative
--
-- Protection: Self.L
-- end of flags
-- End of flags
-- beginning of counts
-- Beginning of counts
ATC_Nesting_Level : ATC_Level := 1;
-- The dynamic level of ATC nesting (currently executing nested
-- asynchronous select statements) in this task.
-- Protection: Self_ID.L.
-- Only Self reads or updates this field.
-- Protection: Self_ID.L. Only Self reads or updates this field.
-- Decrementing it deallocates an Entry_Calls component, and care must
-- be taken that all references to that component are eliminated
-- before doing the decrement. This in turn will require locking
-- a protected object (for a protected entry call) or the Acceptor's
-- lock (for a task entry call).
-- No other task should attempt to read or modify this value.
-- be taken that all references to that component are eliminated before
-- doing the decrement. This in turn will require locking a protected
-- object (for a protected entry call) or the Acceptor's lock (for a
-- task entry call). No other task should attempt to read or modify
-- this value.
Deferral_Level : Natural := 1;
-- This is the number of times that Defer_Abortion has been called by
-- this task without a matching Undefer_Abortion call. Abortion is
-- only allowed when this zero.
-- It is initially 1, to protect the task at startup.
-- Protection: Only updated by Self; access assumed to be atomic.
-- this task without a matching Undefer_Abortion call. Abortion is only
-- allowed when this zero. It is initially 1, to protect the task at
-- startup.
-- Protection: Only updated by Self; access assumed to be atomic
Pending_ATC_Level : ATC_Level_Base := ATC_Level_Infinity;
-- The ATC level to which this task is currently being aborted.
-- If the value is zero, the entire task has "completed".
-- That may be via abort, exception propagation, or normal exit.
-- If the value is ATC_Level_Infinity, the task is not being
-- aborted to any level.
-- If the value is positive, the task has not completed.
-- This should ONLY be modified by
-- Abort_To_Level and Exit_One_ATC_Level.
-- Protection: Self.L.
-- The ATC level to which this task is currently being aborted. If the
-- value is zero, the entire task has "completed". That may be via
-- abort, exception propagation, or normal exit. If the value is
-- ATC_Level_Infinity, the task is not being aborted to any level. If
-- the value is positive, the task has not completed. This should ONLY
-- be modified by Abort_To_Level and Exit_One_ATC_Level.
--
-- Protection: Self.L
Serial_Number : Task_Serial_Number;
-- A growing number to provide some way to check locking
-- rules/ordering.
-- A growing number to provide some way to check locking rules/ordering
Known_Tasks_Index : Integer := -1;
-- Index in the System.Tasking.Debug.Known_Tasks array.
-- Index in the System.Tasking.Debug.Known_Tasks array
User_State : Long_Integer := 0;
-- User-writeable location, for use in debugging tasks;
-- also provides a simple task specific data.
-- User-writeable location, for use in debugging tasks; also provides a
-- simple task specific data.
Direct_Attributes : Direct_Attribute_Array;
-- For task attributes that have same size as Address
@ -951,11 +967,12 @@ package System.Tasking is
-- Bit I is 1 iff Direct_Attributes (I) is defined
Indirect_Attributes : Access_Address;
-- A pointer to chain of records for other attributes that
-- are not address-sized, including all tagged types.
-- A pointer to chain of records for other attributes that are not
-- address-sized, including all tagged types.
Entry_Queues : Task_Entry_Queue_Array (1 .. Entry_Num);
-- An array of task entry queues.
-- An array of task entry queues
--
-- Protection: Self.L. Once a task has set Self.Stage to Completing, it
-- has exclusive access to this field.
end record;
@ -975,18 +992,18 @@ package System.Tasking is
Stack_Size : System.Parameters.Size_Type;
T : Task_Id;
Success : out Boolean);
-- Initialize fields of a TCB and link into global TCB structures
-- Call this only with abort deferred and holding RTS_Lock.
-- Need more documentation, mention T, and describe Success ???
-- Initialize fields of a TCB and link into global TCB structures Call
-- this only with abort deferred and holding RTS_Lock. Need more
-- documentation, mention T, and describe Success ???
private
Null_Task : constant Task_Id := null;
GL_Detect_Blocking : Integer;
pragma Import (C, GL_Detect_Blocking, "__gl_detect_blocking");
-- Global variable exported by the binder generated file. A value
-- equal to 1 indicates that pragma Detect_Blocking is active,
-- while 0 is used for the pragma not being present.
-- Global variable exported by the binder generated file. A value equal to
-- 1 indicates that pragma Detect_Blocking is active, while 0 is used for
-- the pragma not being present.
Detect_Blocking : constant Boolean := GL_Detect_Blocking = 1;

89
gcc/ada/s-tasren.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -154,7 +154,7 @@ package body System.Tasking.Rendezvous is
procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id);
pragma Inline (Boost_Priority);
-- Call this only with abort deferred and holding lock of Acceptor.
-- Call this only with abort deferred and holding lock of Acceptor
procedure Call_Synchronous
(Acceptor : Task_Id;
@ -255,7 +255,7 @@ package body System.Tasking.Rendezvous is
Uninterpreted_Data :=
Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data;
else
-- Case of an aborted task.
-- Case of an aborted task
Uninterpreted_Data := System.Null_Address;
end if;
@ -701,7 +701,7 @@ package body System.Tasking.Rendezvous is
(Self_Id, Entry_Call.Acceptor_Prev_Priority);
else
-- The call does not need to be requeued.
-- The call does not need to be requeued
Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
Entry_Call.Exception_To_Raise := Ex;
@ -712,7 +712,7 @@ package body System.Tasking.Rendezvous is
STPO.Write_Lock (Caller);
-- Done with Caller locked to make sure that Wakeup is not lost.
-- Done with Caller locked to make sure that Wakeup is not lost
if Ex /= Ada.Exceptions.Null_Id then
Transfer_Occurrence
@ -844,7 +844,7 @@ package body System.Tasking.Rendezvous is
Queuing.Select_Task_Entry_Call
(Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
-- Determine the kind and disposition of the select.
-- Determine the kind and disposition of the select
Treatment := Default_Treatment (Select_Mode);
Self_Id.Chosen_Index := No_Rendezvous;
@ -865,7 +865,7 @@ package body System.Tasking.Rendezvous is
end if;
end if;
-- Handle the select according to the disposition selected above.
-- Handle the select according to the disposition selected above
case Treatment is
when Accept_Alternative_Selected =>
@ -882,7 +882,8 @@ package body System.Tasking.Rendezvous is
STPO.Unlock (Self_Id);
when Accept_Alternative_Completed =>
-- Accept body is null, so rendezvous is over immediately.
-- Accept body is null, so rendezvous is over immediately
if Parameters.Runtime_Traces then
Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
@ -896,7 +897,8 @@ package body System.Tasking.Rendezvous is
STPO.Unlock (Caller);
when Accept_Alternative_Open =>
-- Wait for caller.
-- Wait for caller
Self_Id.Open_Accepts := Open_Accepts;
pragma Debug
@ -913,9 +915,9 @@ package body System.Tasking.Rendezvous is
-- Self_Id.Common.Call should already be updated by the Caller if
-- not aborted. It might also be ready to do rendezvous even if
-- this wakes up due to an abortion.
-- Therefore, if the call is not empty we need to do the
-- rendezvous if the accept body is not Null_Body.
-- this wakes up due to an abort. Therefore, if the call is not
-- empty we need to do the rendezvous if the accept body is not
-- Null_Body.
-- Aren't the first two conditions below redundant???
@ -949,7 +951,7 @@ package body System.Tasking.Rendezvous is
Self_Id.Open_Accepts := Open_Accepts;
Self_Id.Common.State := Acceptor_Sleep;
-- Notify ancestors that this task is on a terminate alternative.
-- Notify ancestors that this task is on a terminate alternative
STPO.Unlock (Self_Id);
Utilities.Make_Passive (Self_Id, Task_Completed => False);
@ -1154,7 +1156,7 @@ package body System.Tasking.Rendezvous is
STPO.Write_Lock (Acceptor);
-- If the acceptor is not callable, abort the call and return False.
-- If the acceptor is not callable, abort the call and return False
if not Acceptor.Callable then
STPO.Unlock (Acceptor);
@ -1176,35 +1178,35 @@ package body System.Tasking.Rendezvous is
return False;
end if;
-- Try to serve the call immediately.
-- Try to serve the call immediately
if Acceptor.Open_Accepts /= null then
for J in Acceptor.Open_Accepts'Range loop
if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then
-- Commit acceptor to rendezvous with us.
-- Commit acceptor to rendezvous with us
Acceptor.Chosen_Index := J;
Null_Body := Acceptor.Open_Accepts (J).Null_Body;
Acceptor.Open_Accepts := null;
-- Prevent abort while call is being served.
-- Prevent abort while call is being served
if Entry_Call.State = Now_Abortable then
Entry_Call.State := Was_Abortable;
end if;
if Acceptor.Terminate_Alternative then
-- Cancel terminate alternative.
-- See matching code in Selective_Wait and
-- Vulnerable_Complete_Master.
-- Cancel terminate alternative. See matching code in
-- Selective_Wait and Vulnerable_Complete_Master.
Acceptor.Terminate_Alternative := False;
Acceptor.Awake_Count := Acceptor.Awake_Count + 1;
if Acceptor.Awake_Count = 1 then
-- Notify parent that acceptor is awake.
-- Notify parent that acceptor is awake
pragma Assert (Parent.Awake_Count > 0);
@ -1220,7 +1222,8 @@ package body System.Tasking.Rendezvous is
end if;
if Null_Body then
-- Rendezvous is over immediately.
-- Rendezvous is over immediately
STPO.Wakeup (Acceptor, Acceptor_Sleep);
STPO.Unlock (Acceptor);
@ -1237,8 +1240,8 @@ package body System.Tasking.Rendezvous is
else
Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor);
-- For terminate_alternative, acceptor may not be
-- asleep yet, so we skip the wakeup
-- For terminate_alternative, acceptor may not be asleep
-- yet, so we skip the wakeup
if Acceptor.Common.State /= Runnable then
STPO.Wakeup (Acceptor, Acceptor_Sleep);
@ -1255,7 +1258,7 @@ package body System.Tasking.Rendezvous is
end if;
end loop;
-- The acceptor is accepting, but not this entry.
-- The acceptor is accepting, but not this entry
end if;
-- If the acceptor was ready to accept this call,
@ -1360,11 +1363,11 @@ package body System.Tasking.Rendezvous is
else
-- This is an asynchronous call
-- Abortion must already be deferred by the compiler-generated
-- code. Without this, an abortion that occurs between the time
-- that this call is made and the time that the abortable part's
-- cleanup handler is set up might miss the cleanup handler and
-- leave the call pending.
-- Abort must already be deferred by the compiler-generated code.
-- Without this, an abort that occurs between the time that this
-- call is made and the time that the abortable part's cleanup
-- handler is set up might miss the cleanup handler and leave the
-- call pending.
Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
pragma Debug
@ -1421,7 +1424,7 @@ package body System.Tasking.Rendezvous is
Unlock_RTS;
end if;
-- Note: following assignment needs to be atomic.
-- Note: following assignment needs to be atomic
Rendezvous_Successful := Entry_Call.State = Done;
end if;
@ -1506,7 +1509,7 @@ package body System.Tasking.Rendezvous is
Queuing.Select_Task_Entry_Call
(Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
-- Determine the kind and disposition of the select.
-- Determine the kind and disposition of the select
Treatment := Default_Treatment (Select_Mode);
Self_Id.Chosen_Index := No_Rendezvous;
@ -1528,7 +1531,7 @@ package body System.Tasking.Rendezvous is
end if;
end if;
-- Handle the select according to the disposition selected above.
-- Handle the select according to the disposition selected above
case Treatment is
when Accept_Alternative_Selected =>
@ -1555,7 +1558,8 @@ package body System.Tasking.Rendezvous is
STPO.Unlock (Caller);
when Accept_Alternative_Open =>
-- Wait for caller.
-- Wait for caller
Self_Id.Open_Accepts := Open_Accepts;
@ -1563,9 +1567,8 @@ package body System.Tasking.Rendezvous is
-- Wakeup_Time is reached.
-- Try to remove calls to Sleep in the loop below by letting the
-- caller a chance of getting ready immediately, using Unlock &
-- Yield.
-- See similar action in Wait_For_Completion & Wait_For_Call.
-- caller a chance of getting ready immediately, using Unlock
-- Yield. See similar action in Wait_For_Completion/Wait_For_Call.
if Single_Lock then
Unlock_RTS;
@ -1622,9 +1625,9 @@ package body System.Tasking.Rendezvous is
-- Self_Id.Common.Call should already be updated by the Caller if
-- not aborted. It might also be ready to do rendezvous even if
-- this wakes up due to an abortion.
-- Therefore, if the call is not empty we need to do the
-- rendezvous if the accept body is not Null_Body.
-- this wakes up due to an abort. Therefore, if the call is not
-- empty we need to do the rendezvous if the accept body is not
-- Null_Body.
if Self_Id.Chosen_Index /= No_Rendezvous
and then Self_Id.Common.Call /= null
@ -1648,7 +1651,7 @@ package body System.Tasking.Rendezvous is
-- for several reasons:
-- 1) Delay is expired
-- 2) Pending_Action needs to be checked
-- (Abortion, Priority change)
-- (Abort, Priority change)
-- 3) Spurious wakeup
Self_Id.Open_Accepts := null;
@ -1753,7 +1756,7 @@ package body System.Tasking.Rendezvous is
Entry_Call.Called_PO := Null_Address;
Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
-- Note: the caller will undefer abortion on return (see WARNING above)
-- Note: the caller will undefer abort on return (see WARNING above)
if Single_Lock then
Lock_RTS;
@ -1820,7 +1823,7 @@ package body System.Tasking.Rendezvous is
Write_Lock (Self_Id);
end if;
-- Check if this task has been aborted while the lock was released.
-- Check if this task has been aborted while the lock was released
if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
Self_Id.Open_Accepts := null;

52
gcc/ada/s-tassta.adb
View File

@ -36,24 +36,24 @@ pragma Polling (Off);
-- tasking operations. It causes infinite loops and other problems.
with Ada.Exceptions;
-- used for Raise_Exception
-- Used for Raise_Exception
with System.Tasking.Debug;
-- used for enabling tasking facilities with gdb
-- Used for enabling tasking facilities with gdb
with System.Address_Image;
-- used for the function itself.
-- Used for the function itself
with System.Parameters;
-- used for Size_Type
-- Used for Size_Type
-- Single_Lock
-- Runtime_Traces
with System.Task_Info;
-- used for Task_Info_Type
-- Used for Task_Info_Type
with System.Task_Primitives.Operations;
-- used for Finalize_Lock
-- Used for Finalize_Lock
-- Enter_Task
-- Write_Lock
-- Unlock
@ -64,11 +64,11 @@ with System.Task_Primitives.Operations;
-- New_ATCB
with System.Soft_Links;
-- These are procedure pointers to non-tasking routines that use
-- task specific data. In the absence of tasking, these routines
-- refer to global data. In the presense of tasking, they must be
-- replaced with pointers to task-specific versions.
-- Also used for Create_TSD, Destroy_TSD, Get_Current_Excep
-- These are procedure pointers to non-tasking routines that use task
-- specific data. In the absence of tasking, these routines refer to global
-- data. In the presense of tasking, they must be replaced with pointers to
-- task-specific versions. Also used for Create_TSD, Destroy_TSD,
-- Get_Current_Excep
with System.Tasking.Initialization;
-- Used for Remove_From_All_Tasks_List
@ -79,7 +79,7 @@ with System.Tasking.Initialization;
-- Initialize_Attributes_Link
pragma Elaborate_All (System.Tasking.Initialization);
-- This insures that tasking is initialized if any tasks are created.
-- This insures that tasking is initialized if any tasks are created
with System.Tasking.Utilities;
-- Used for Make_Passive
@ -98,22 +98,22 @@ with System.Finalization_Implementation;
-- Used for System.Finalization_Implementation.Finalize_Global_List
with System.Secondary_Stack;
-- used for SS_Init
-- Used for SS_Init
with System.Storage_Elements;
-- used for Storage_Array
-- Used for Storage_Array
with System.Restrictions;
-- used for Abort_Allowed
-- Used for Abort_Allowed
with System.Standard_Library;
-- used for Exception_Trace
-- Used for Exception_Trace
with System.Traces.Tasking;
-- used for Send_Trace_Info
-- Used for Send_Trace_Info
with Unchecked_Deallocation;
-- To recover from failure of ATCB initialization.
-- To recover from failure of ATCB initialization
package body System.Tasking.Stages is
@ -787,11 +787,11 @@ package body System.Tasking.Stages is
Self_ID.Callable := False;
-- Exit level 2 master, for normal tasks in library-level packages.
-- Exit level 2 master, for normal tasks in library-level packages
Complete_Master;
-- Force termination of "independent" library-level server tasks.
-- Force termination of "independent" library-level server tasks
Lock_RTS;
@ -977,7 +977,7 @@ package body System.Tasking.Stages is
-- clean ups associated with the exception handler that need to
-- access task specific data.
-- Defer abortion so that this task can't be aborted while exiting
-- Defer abort so that this task can't be aborted while exiting
when Standard'Abort_Signal =>
Initialization.Defer_Abort_Nestable (Self_ID);
@ -1209,7 +1209,7 @@ package body System.Tasking.Stages is
-- The activator raises a Tasking_Error if any task it is activating
-- is completed before the activation is done. However, if the reason
-- for the task completion is an abortion, we do not raise an exception.
-- for the task completion is an abort, we do not raise an exception.
-- See RM 9.2(5).
if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then
@ -1392,7 +1392,7 @@ package body System.Tasking.Stages is
pragma Assert (Self_ID.Common.Wait_Count = 0);
-- Force any remaining dependents to terminate, by aborting them.
-- Force any remaining dependents to terminate by aborting them
if not Single_Lock then
Lock_RTS;
@ -1461,8 +1461,8 @@ package body System.Tasking.Stages is
Unlock (Self_ID);
end if;
-- We don't wake up for abortion here. We are already terminating
-- just as fast as we can, so there is no point.
-- We don't wake up for abort here. We are already terminating just as
-- fast as we can, so there is no point.
-- Remove terminated tasks from the list of Self_ID's dependents, but
-- don't free their ATCBs yet, because of lock order restrictions,
@ -1687,7 +1687,7 @@ package body System.Tasking.Stages is
-- Package elaboration code
begin
-- Establish the Adafinal softlink.
-- Establish the Adafinal softlink
-- This is not done inside the central RTS initialization routine
-- to avoid with-ing this package from System.Tasking.Initialization.

8
gcc/ada/s-tassta.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -121,9 +121,9 @@ package System.Tasking.Stages is
-- activate_tasks (_chain'unchecked_access);
procedure Abort_Tasks (Tasks : Task_List);
-- Compiler interface only. Do not call from within the RTS.
-- Initiate abortion, however, the actual abortion is done by abortee by
-- means of Abort_Handler and Abort_Undefer
-- Compiler interface only. Do not call from within the RTS. Initiate
-- abort, however, the actual abort is done by abortee by means of
-- Abort_Handler and Abort_Undefer
--
-- source code:
-- Abort T1, T2;

20
gcc/ada/s-tasuti.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -72,9 +72,9 @@ package System.Tasking.Utilities is
-- the environment task (because every independent task depends on it),
-- this counter is protected by the environment task's lock.
------------------------------------
-- Task Abortion related routines --
------------------------------------
---------------------------------
-- Task Abort Related Routines --
---------------------------------
procedure Cancel_Queued_Entry_Calls (T : Task_Id);
-- Cancel any entry calls queued on target task.
@ -93,13 +93,13 @@ package System.Tasking.Utilities is
-- (3) always aborts whole task
procedure Abort_Tasks (Tasks : Task_List);
-- Abort_Tasks is called to initiate abortion, however, the actual
-- abortion is done by abortee by means of Abort_Handler
-- Abort_Tasks is called to initiate abort, however, the actual
-- aborti is done by aborted task by means of Abort_Handler
procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean);
-- Update counts to indicate current task is either terminated
-- or accepting on a terminate alternative.
-- Call holding no locks except Global_Task_Lock when calling from
-- Terminate_Task, and RTS_Lock when Single_Lock is True.
-- Update counts to indicate current task is either terminated or
-- accepting on a terminate alternative. Call holding no locks except
-- Global_Task_Lock when calling from Terminate_Task, and RTS_Lock when
-- Single_Lock is True.
end System.Tasking.Utilities;

43
gcc/ada/s-tataat.ads
View File

@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2004, Ada Core Technologies --
-- Copyright (C) 1995-2005, Ada Core Technologies --
-- --
-- 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- --
@ -32,13 +32,13 @@
-- --
------------------------------------------------------------------------------
-- This package provides support for the body of Ada.Task_Attributes.
-- This package provides support for the body of Ada.Task_Attributes
with Ada.Finalization;
-- used for Limited_Controlled
-- Used for Limited_Controlled
with System.Storage_Elements;
-- used for Integer_Address
-- Used for Integer_Address
package System.Tasking.Task_Attributes is
@ -52,8 +52,8 @@ package System.Tasking.Task_Attributes is
function To_Access_Node is new Unchecked_Conversion
(Access_Address, Access_Node);
-- Used to fetch pointer to indirect attribute list. Declaration is
-- in spec to avoid any problems with aliasing assumptions.
-- Used to fetch pointer to indirect attribute list. Declaration is in
-- spec to avoid any problems with aliasing assumptions.
type Dummy_Wrapper;
type Access_Dummy_Wrapper is access all Dummy_Wrapper;
@ -67,7 +67,7 @@ package System.Tasking.Task_Attributes is
-- of type Wrapper, no Dummy_Wrapper objects are ever created.
type Deallocator is access procedure (P : in out Access_Node);
-- Called to deallocate an Wrapper. P is a pointer to a Node within.
-- Called to deallocate an Wrapper. P is a pointer to a Node within
type Instance;
@ -78,11 +78,11 @@ package System.Tasking.Task_Attributes is
Initial_Value : aliased System.Storage_Elements.Integer_Address;
Index : Direct_Index;
-- The index of the TCB location used by this instantiation,
-- if it is stored in the TCB, otherwise zero.
-- The index of the TCB location used by this instantiation, if it is
-- stored in the TCB, otherwise zero.
Next : Access_Instance;
-- Next instance in All_Attributes list.
-- Next instance in All_Attributes list
end record;
procedure Finalize (X : in out Instance);
@ -93,12 +93,11 @@ package System.Tasking.Task_Attributes is
Next : Access_Node;
end record;
-- The following type is a stand-in for the actual
-- wrapper type, which is different for each instantiation
-- of Ada.Task_Attributes.
-- The following type is a stand-in for the actual wrapper type, which is
-- different for each instantiation of Ada.Task_Attributes.
type Dummy_Wrapper is record
Noed : aliased Node;
Dummy_Node : aliased Node;
Value : aliased Attribute;
-- The generic formal type, may be controlled
@ -110,23 +109,23 @@ package System.Tasking.Task_Attributes is
-- Ensure that the designated object is always strictly enough aligned.
In_Use : Direct_Index_Vector := 0;
-- is True for direct indices that are already used.
-- Set True for direct indices that are already used (True??? type???)
All_Attributes : Access_Instance;
-- A linked list of all indirectly access attributes,
-- which includes all those that require finalization.
-- A linked list of all indirectly access attributes, which includes all
-- those that require finalization.
procedure Initialize_Attributes (T : Task_Id);
-- Initialize all attributes created via Ada.Task_Attributes for T.
-- This must be called by the creator of the task, inside Create_Task,
-- via soft-link Initialize_Attributes_Link. On entry, abortion must
-- be deferred and the caller must hold no locks
-- Initialize all attributes created via Ada.Task_Attributes for T. This
-- must be called by the creator of the task, inside Create_Task, via
-- soft-link Initialize_Attributes_Link. On entry, abort must be deferred
-- and the caller must hold no locks
procedure Finalize_Attributes (T : Task_Id);
-- Finalize all attributes created via Ada.Task_Attributes for T.
-- This is to be called by the task after it is marked as terminated
-- (and before it actually dies), inside Vulnerable_Free_Task, via the
-- soft-link Finalize_Attributes_Link. On entry, abortion must be deferred
-- soft-link Finalize_Attributes_Link. On entry, abort must be deferred
-- and T.L must be write-locked.
end System.Tasking.Task_Attributes;

54
gcc/ada/s-tpoben.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1998-2005, 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- --
@ -31,39 +31,40 @@
-- --
------------------------------------------------------------------------------
-- This package contains all the simple primitives related to
-- Protected_Objects with entries (i.e init, lock, unlock).
-- This package contains all the simple primitives related to protected
-- objects with entries (i.e init, lock, unlock).
-- The handling of protected objects with no entries is done in
-- System.Tasking.Protected_Objects, the complex routines for protected
-- objects with entries in System.Tasking.Protected_Objects.Operations.
-- The split between Entries and Operations is needed to break circular
-- dependencies inside the run time.
-- Note: the compiler generates direct calls to this interface, via Rtsfind.
-- Note: the compiler generates direct calls to this interface, via Rtsfind
with Ada.Exceptions;
-- used for Exception_Occurrence_Access
-- Used for Exception_Occurrence_Access
-- Raise_Exception
with System.Task_Primitives.Operations;
-- used for Initialize_Lock
-- Used for Initialize_Lock
-- Write_Lock
-- Unlock
-- Get_Priority
-- Wakeup
with System.Tasking.Initialization;
-- used for Defer_Abort,
-- Used for Defer_Abort,
-- Undefer_Abort,
-- Change_Base_Priority
pragma Elaborate_All (System.Tasking.Initialization);
-- this insures that tasking is initialized if any protected objects are
-- This insures that tasking is initialized if any protected objects are
-- created.
with System.Parameters;
-- used for Single_Lock
-- Used for Single_Lock
package body System.Tasking.Protected_Objects.Entries is
@ -103,8 +104,9 @@ package body System.Tasking.Protected_Objects.Entries is
end if;
if Ceiling_Violation then
-- Dip our own priority down to ceiling of lock.
-- See similar code in Tasking.Entry_Calls.Lock_Server.
-- Dip our own priority down to ceiling of lock. See similar code in
-- Tasking.Entry_Calls.Lock_Server.
STPO.Write_Lock (Self_ID);
Old_Base_Priority := Self_ID.Common.Base_Priority;
@ -130,7 +132,7 @@ package body System.Tasking.Protected_Objects.Entries is
Object.Pending_Action := True;
end if;
-- Send program_error to all tasks still queued on this object.
-- Send program_error to all tasks still queued on this object
for E in Object.Entry_Queues'Range loop
Entry_Call := Object.Entry_Queues (E).Head;
@ -229,10 +231,10 @@ package body System.Tasking.Protected_Objects.Entries is
(Program_Error'Identity, "Protected Object is finalized");
end if;
-- If pragma Detect_Blocking is active then Program_Error must
-- be raised if this potentially blocking operation is called from
-- a protected action, and the protected object nesting level
-- must be increased.
-- If pragma Detect_Blocking is active then Program_Error must be
-- raised if this potentially blocking operation is called from a
-- protected action, and the protected object nesting level must be
-- increased.
if Detect_Blocking then
declare
@ -242,8 +244,8 @@ package body System.Tasking.Protected_Objects.Entries is
Ada.Exceptions.Raise_Exception
(Program_Error'Identity, "potentially blocking operation");
else
-- We are entering in a protected action, so that we
-- increase the protected object nesting level.
-- We are entering in a protected action, so that we increase
-- the protected object nesting level.
Self_Id.Common.Protected_Action_Nesting :=
Self_Id.Common.Protected_Action_Nesting + 1;
@ -251,15 +253,15 @@ package body System.Tasking.Protected_Objects.Entries is
end;
end if;
-- The lock is made without defering abortion.
-- The lock is made without defering abort
-- Therefore the abortion has to be deferred before calling this
-- routine. This means that the compiler has to generate a Defer_Abort
-- call before the call to Lock.
-- Therefore the abort has to be deferred before calling this routine.
-- This means that the compiler has to generate a Defer_Abort call
-- before the call to Lock.
-- The caller is responsible for undeferring abortion, and compiler
-- The caller is responsible for undeferring abort, and compiler
-- generated calls must be protected with cleanup handlers to ensure
-- that abortion is undeferred in all cases.
-- that abort is undeferred in all cases.
pragma Assert (STPO.Self.Deferral_Level > 0);
Write_Lock (Object.L'Access, Ceiling_Violation);
@ -302,8 +304,8 @@ package body System.Tasking.Protected_Objects.Entries is
Ada.Exceptions.Raise_Exception
(Program_Error'Identity, "potentially blocking operation");
else
-- We are entering in a protected action, so that we
-- increase the protected object nesting level.
-- We are entering in a protected action, so that we increase
-- the protected object nesting level.
Self_Id.Common.Protected_Action_Nesting :=
Self_Id.Common.Protected_Action_Nesting + 1;

31
gcc/ada/s-tpobop.ads
View File

@ -2,12 +2,11 @@
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . --
-- O P E R A T I O N S --
-- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -32,19 +31,20 @@
-- --
------------------------------------------------------------------------------
-- This package contains all the extended primitives related to
-- Protected_Objects with entries.
-- This package contains all the extended primitives related to protected
-- objects with entries.
-- The handling of protected objects with no entries is done in
-- System.Tasking.Protected_Objects, the simple routines for protected
-- objects with entries in System.Tasking.Protected_Objects.Entries.
-- The split between Entries and Operations is needed to break circular
-- objects with entries in System.Tasking.Protected_Objects.Entries. The
-- split between Entries and Operations is needed to break circular
-- dependencies inside the run time.
-- Note: the compiler generates direct calls to this interface, via Rtsfind.
-- Any changes to this interface may require corresponding compiler changes.
with Ada.Exceptions;
-- used for Exception_Id
-- Used for Exception_Id
with System.Tasking.Protected_Objects.Entries;
@ -108,7 +108,7 @@ package System.Tasking.Protected_Objects.Operations is
-- barriers, so this routine keeps checking barriers until all of
-- them are closed.
--
-- This must be called with abortion deferred and with the corresponding
-- This must be called with abort deferred and with the corresponding
-- object locked.
--
-- If Unlock_Object is set True, then Object is unlocked on return,
@ -173,7 +173,7 @@ package System.Tasking.Protected_Objects.Operations is
(Object : Entries.Protection_Entries'Class;
E : Protected_Entry_Index)
return Natural;
-- Return the number of entry calls to E on Object.
-- Return the number of entry calls to E on Object
function Protected_Entry_Caller
(Object : Entries.Protection_Entries'Class) return Task_Id;
@ -181,7 +181,7 @@ package System.Tasking.Protected_Objects.Operations is
-- being handled. This will only work if called from within an entry
-- body, as required by the LRM (C.7.1(14)).
-- For internal use only:
-- For internal use only
procedure PO_Do_Or_Queue
(Self_ID : Task_Id;
@ -189,7 +189,7 @@ package System.Tasking.Protected_Objects.Operations is
Entry_Call : Entry_Call_Link;
With_Abort : Boolean);
-- This procedure either executes or queues an entry call, depending
-- on the status of the corresponding barrier. It assumes that abortion
-- on the status of the corresponding barrier. It assumes that abort
-- is deferred and that the specified object is locked.
private
@ -201,10 +201,9 @@ private
pragma Volatile (Communication_Block);
-- ?????
-- The Communication_Block seems to be a relic.
-- At the moment, the compiler seems to be generating
-- unnecessary conditional code based on this block.
-- See the code generated for async. select with task entry
-- The Communication_Block seems to be a relic. At the moment, the
-- compiler seems to be generating unnecessary conditional code based on
-- this block. See the code generated for async. select with task entry
-- call for another way of solving this.
end System.Tasking.Protected_Objects.Operations;

14
gcc/ada/tbuild.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -72,16 +72,16 @@ package Tbuild is
function Make_DT_Component
(Loc : Source_Ptr;
Typ : Entity_Id;
I : Positive) return Node_Id;
-- Gives a reference to the Ith component of the Dispatch Table of
N : Positive) return Node_Id;
-- Gives a reference to the Nth component of the Dispatch Table of
-- a given Tagged Type.
--
-- I = 1 --> Inheritance_Depth
-- I = 2 --> Tags (array of ancestors)
-- I = 3, 4 --> predefined primitive
-- N = 1 --> Inheritance_Depth
-- N = 2 --> Tags (array of ancestors)
-- N = 3, 4 --> predefined primitive
-- function _Size (X : Typ) return Long_Long_Integer;
-- function _Equality (X : Typ; Y : Typ'Class) return Boolean;
-- I >= 5 --> User-Defined Primitive Operations
-- N >= 5 --> User-Defined Primitive Operations
function Make_DT_Access
(Loc : Source_Ptr; Rec : Node_Id; Typ : Entity_Id) return Node_Id;

2
gcc/ada/utils2.c
View File

@ -679,7 +679,7 @@ build_binary_op (enum tree_code op_code, tree result_type,
|| (TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0)))
== ARRAY_TYPE))
&& (0 == (best_type
== find_common_type (right_type,
= find_common_type (right_type,
TREE_TYPE (TREE_OPERAND
(right_operand, 0))))
|| right_type != best_type))