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

a-calend-mingw.adb: Add call to OS_Primitives.Initialize; 

* a-calend-mingw.adb: Add call to OS_Primitives.Initialize;

	* s-taprop-mingw.adb, s-taprop-vms.adb, s-taprop-solaris.adb,
	s-taprop-os2.adb, s-taprop-irix-athread.adb, s-taprop-linux.adb,
	s-taprop-hpux-dce.adb, s-taprop-irix.adb, s-taprop-tru64.adb,
	s-taprop-lynxos.adb: Move with clauses outside Warnings Off now that
	dependent units are Preelaborate.
	(Initialize): Call Interrupt_Managemeent.Initialize and
	OS_Primitives.Initialize to ensure proper initialization of this unit.
	Remove use of System.Soft_Links
	Make this unit Preelaborate.

	* s-stache.ads, s-taspri-vxworks.ads, s-taspri-mingw.ads,
	s-taspri-vms.ads, s-tasinf-solaris.ads, s-taspri-os2.ads,
	s-taspri-lynxos.ads, s-taspri-hpux-dce.ads, s-taspri-tru64.ads,
	s-tasinf-tru64.ads, s-tasinf-irix.ads, s-tasinf-irix-athread.ads,
	s-proinf-irix-athread.adb, s-proinf-irix-athread.ads,
	s-tratas.ads, s-tasinf.ads: Minor reformatting.
	Add pragma Preelaborate, since these packages are suitable for this
	categorization.
	Update comments.

	* s-traent-vms.ads, s-intman-dummy.adb,
	s-taprop-dummy.adb: Make this unit Preelaborate.

	* s-osprim-vxworks.adb, s-osprim-vms.adb, s-osprim-vms.ads,
	s-osprim-mingw.adb, s-intman-vxworks.ads, s-intman-vxworks.adb,
	s-intman-vms.adb, s-intman-mingw.adb, s-intman-vms.ads,
	s-osprim-unix.adb, s-osprim-os2.adb, s-osprim-solaris.adb,
	s-intman-solaris.adb, s-intman-irix-athread.adb,
	s-intman-irix.adb: Mark this unit Preelaborate.
	(Initialize): New procedure.
	Update comments.

	* s-taspri-linux.ads: Removed.

	* s-tpopsp-solaris.adb (Initialize): Create the key in this procedure,
	as done by other implementations (e.g. posix).

	* s-taprop.ads (Timed_Delay): Update spec since the caller now is
	responsible for deferring abort.
	Mark this unit Preelaborate.

	* s-taprob.adb, s-tarest.adb: Call System.Tasking.Initialize to ensure
	proper initialization of the tasking run-time.

	* s-tasdeb.ads: Mark this unit Preelaborate.
	(Known_Tasks): Add explicit default value to avoid elaboration code.

	* s-inmaop-vms.adb (Elaboration code): Add call to
	Interrupt_Management.Initialize since the elaboration code depends on
	proper initialization of this package.

	* s-intman.ads, s-inmaop-posix.adb, s-intman-posix.adb,
	s-osprim.ads, s-taprop-posix.adb, s-taspri-posix.ads,
	s-osprim-posix.adb: Make this unit Preelaborate.

	* a-calend.adb: Add call to OS_Primitives.Initialize

	* a-elchha.adb: Update use of Except.Id.Full_Name.
	Minor reformatting.
	Remove use of Ada.Exceptions.Traceback when possible, cleaner.

	* a-dynpri.adb, a-sytaco.adb, a-sytaco.ads:
	Move with clauses outside Warnings Off now that dependent units are
	Preelaborate.
	Use raise xxx with "..."; Ada 2005 form.

	* a-taside.ads, a-taside.adb:
	Remove some dependencies, to make it easier to make this unit truly
	Preelaborate.
	Rewrite some code to be conformant with Preelaborate rules.

	* g-os_lib.adb: Remove non-preelaborate code so that this unit can be
	marked Preelaborate in the future.

	* s-proinf.ads, g-string.ads, s-auxdec.ads, s-auxdec-vms_64.ads: Make
	these units Preelaborate.

	* s-exctab.adb: Update use of Except.Id.Full_Name.

	* s-soflin.ads, s-soflin.adb: Mark this unit Preelaborate_05.
	(Set_Exc_Stack_Addr_Soft, Get_Exc_Stack_Addr_NT, Set_Exc_Stack_Addr_NT,
	Set_Exc_Stack_Addr): Removed, no longer used.
	Remove reference to *Machine_State_Addr*, no longer needed.

	* s-stalib.ads: Mark this unit as Preelaborate[_05].
	(Exception_Data): Full_Name is now a System.Address so that this unit
	can be made Preelaborate.
	Clean up/simplify code thanks to Full_Name being a System.Address.
	Remove obsolete pragma Suppress (All_Checks), no longer needed.

	* s-taskin.ads, s-taskin.adb:
	Move with clauses outside Warnings Off now that dependent units are
	Preelaborate.
	Make this unit Preelaborate.
	(Initialize): New proceduure, replace elaboration code and makes the
	set up of the tasking run-time cleaner.
	(Detect_Blocking): Now a function instead of a deferred boolean, to
	obey Preelaborate rules.

	* s-tassta.adb (Finalize_Global_Tasks): Remove Get/Set_Exc_Stack_Addr
	soft links, no longer used.

	* s-traces.ads, s-traent.ads: Add pragma Preelaborate, since these
	packages are suitable for this categorization.

	* s-solita.adb: Replace use of Ada.Exception by raise xxx with "..."
	since we compile run-time sources in Ada 2005 mode.
	(Timed_Delay_T): Call Abort_Defer/Undefer around Timed_Delay, to
	avoid having s-taprop*.adb depend on s-soflin and to avoid code
	duplication.
	Remove reference to *Machine_State_Addr*, no longer needed.

From-SVN: r103847
This commit is contained in:
Arnaud Charlet 2005-09-05 09:46:06 +02:00
parent ca88769356
commit 3b91d88ea1
81 changed files with 858 additions and 1322 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/ada/a-calend-mingw.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1997-2002 Free Software Foundation, Inc. --
-- Copyright (C) 1997-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- --
@ -31,7 +31,7 @@
-- --
------------------------------------------------------------------------------
-- This is the Windows NT/95 version.
-- This is the Windows NT/95 version
with System.OS_Primitives;
-- used for Clock
@ -262,7 +262,7 @@ package body Ada.Calendar is
end if;
-- Date_Int is the number of seconds from Epoch.
-- Date_Int is the number of seconds from Epoch
Date_Int := Long_Long_Integer
(Int_Date * Sec_Unit / system_time_ns) + epoch_1970;
@ -391,4 +391,6 @@ package body Ada.Calendar is
return DY;
end Year;
begin
System.OS_Primitives.Initialize;
end Ada.Calendar;

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

@ -476,4 +476,6 @@ package body Ada.Calendar is
return DY;
end Year;
begin
System.OS_Primitives.Initialize;
end Ada.Calendar;

37
gcc/ada/a-dynpri.adb
View File

@ -31,11 +31,6 @@
-- --
------------------------------------------------------------------------------
pragma Warnings (Off);
-- Allow withing of non-Preelaborated units in Ada 2005 mode where this
-- package will be categorized as Preelaborate. See AI-362 for details.
-- It is safe in the context of the run-time to violate the rules!
with Ada.Task_Identification;
-- used for Task_Id
-- Current_Task
@ -52,26 +47,22 @@ with System.Task_Primitives.Operations;
with System.Tasking;
-- used for Task_Id
with Ada.Exceptions;
-- used for Raise_Exception
with System.Tasking.Initialization;
-- used for Defer/Undefer_Abort
with System.Parameters;
-- used for Single_Lock
with Unchecked_Conversion;
with System.Soft_Links;
-- use for Abort_Defer
-- Abort_Undefer
pragma Warnings (On);
with Unchecked_Conversion;
package body Ada.Dynamic_Priorities is
package STPO renames System.Task_Primitives.Operations;
package SSL renames System.Soft_Links;
use System.Parameters;
use System.Tasking;
use Ada.Exceptions;
function Convert_Ids is new
Unchecked_Conversion
@ -92,13 +83,11 @@ package body Ada.Dynamic_Priorities is
begin
if Target = Convert_Ids (Ada.Task_Identification.Null_Task_Id) then
Raise_Exception (Program_Error'Identity,
Error_Message & "null task");
raise Program_Error with Error_Message & "null task";
end if;
if Task_Identification.Is_Terminated (T) then
Raise_Exception (Tasking_Error'Identity,
Error_Message & "null task");
raise Tasking_Error with Error_Message & "null task";
end if;
return Target.Common.Base_Priority;
@ -121,16 +110,14 @@ package body Ada.Dynamic_Priorities is
begin
if Target = Convert_Ids (Ada.Task_Identification.Null_Task_Id) then
Raise_Exception (Program_Error'Identity,
Error_Message & "null task");
raise Program_Error with Error_Message & "null task";
end if;
if Task_Identification.Is_Terminated (T) then
Raise_Exception (Tasking_Error'Identity,
Error_Message & "terminated task");
raise Tasking_Error with Error_Message & "terminated task";
end if;
Initialization.Defer_Abort (Self_ID);
SSL.Abort_Defer.all;
if Single_Lock then
STPO.Lock_RTS;
@ -148,7 +135,7 @@ package body Ada.Dynamic_Priorities is
STPO.Unlock_RTS;
end if;
-- Yield is needed to enforce FIFO task dispatching.
-- Yield is needed to enforce FIFO task dispatching
-- LL Set_Priority is made while holding the RTS lock so that it
-- is inheriting high priority until it release all the RTS locks.
@ -175,7 +162,7 @@ package body Ada.Dynamic_Priorities is
end if;
end if;
Initialization.Undefer_Abort (Self_ID);
SSL.Abort_Undefer.all;
end Set_Priority;
end Ada.Dynamic_Priorities;

9
gcc/ada/a-elchha.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2003-2004 Free Software Foundation, Inc. --
-- Copyright (C) 2003-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@ -37,6 +37,8 @@
-- Default version for most targets
with System.Standard_Library; use System.Standard_Library;
procedure Ada.Exceptions.Last_Chance_Handler
(Except : Exception_Occurrence)
is
@ -88,7 +90,7 @@ begin
-- really an exception at all. We recognize this by the fact that
-- it is the only exception whose name starts with underscore.
if Except.Id.Full_Name.all (1) = '_' then
if To_Ptr (Except.Id.Full_Name) (1) = '_' then
To_Stderr (Nline);
To_Stderr ("Execution terminated by abort of environment task");
To_Stderr (Nline);
@ -100,7 +102,8 @@ begin
elsif Except.Num_Tracebacks = 0 then
To_Stderr (Nline);
To_Stderr ("raised ");
To_Stderr (Except.Id.Full_Name.all (1 .. Except.Id.Name_Length - 1));
To_Stderr
(To_Ptr (Except.Id.Full_Name) (1 .. Except.Id.Name_Length - 1));
if Exception_Message_Length (Except) /= 0 then
To_Stderr (" : ");

7
gcc/ada/a-sytaco.adb
View File

@ -31,11 +31,6 @@
-- --
------------------------------------------------------------------------------
pragma Warnings (Off);
-- Allow withing of non-Preelaborated units in Ada 2005 mode where this
-- package will be categorized as Preelaborate. See AI-362 for details.
-- It is safe in the context of the run-time to violate the rules!
with System.Tasking;
-- Used for Detect_Blocking
-- Self
@ -51,8 +46,6 @@ with System.Task_Primitives.Operations;
-- Set_True
-- Suspend_Until_True
pragma Warnings (On);
package body Ada.Synchronous_Task_Control is
----------------

16
gcc/ada/a-sytaco.ads
View File

@ -35,22 +35,15 @@
-- --
------------------------------------------------------------------------------
pragma Warnings (Off);
-- Allow withing of non-Preelaborated units in Ada 2005 mode where this
-- package will be implicitly categorized as Preelaborate. See AI-362 for
-- details. It is safe in the context of the run-time to violate the rules!
with System.Task_Primitives;
-- Used for Suspension_Object
with Ada.Finalization;
-- Used for Limited_Controlled
pragma Warnings (On);
package Ada.Synchronous_Task_Control is
pragma Preelaborate_05 (Synchronous_Task_Control);
-- In accordance with Ada 2005 AI-362
pragma Preelaborate_05;
-- In accordance with Ada 2005 AI-362
type Suspension_Object is limited private;
@ -71,12 +64,13 @@ private
-- Finalization for Suspension_Object
type Suspension_Object is
new Ada.Finalization.Limited_Controlled with record
new Ada.Finalization.Limited_Controlled with
record
SO : System.Task_Primitives.Suspension_Object;
-- Use low-level suspension objects so that the synchronization
-- functionality provided by this object can be achieved using
-- efficient operating system primitives.
end record;
end record;
pragma Inline (Set_True);
pragma Inline (Set_False);

73
gcc/ada/a-taside.adb
View File

@ -31,33 +31,29 @@
-- --
------------------------------------------------------------------------------
with System.Address_Image;
with System.Parameters;
with System.Soft_Links;
with System.Task_Primitives.Operations;
with System.Tasking;
with Unchecked_Conversion;
pragma Warnings (Off);
-- Allow withing of non-Preelaborated units in Ada 2005 mode where this
-- package will be categorized as Preelaborate. See AI-362 for details.
-- It is safe in the context of the run-time to violate the rules!
with System.Address_Image;
-- used for the function itself
with System.Tasking;
-- used for Task_List
with System.Tasking.Stages;
-- used for Terminated
-- Abort_Tasks
with System.Tasking.Rendezvous;
-- used for Callable
with System.Task_Primitives.Operations;
-- used for Self
with Unchecked_Conversion;
pragma Warnings (Off);
pragma Warnings (On);
package body Ada.Task_Identification is
use System.Parameters;
package STPO renames System.Task_Primitives.Operations;
-----------------------
-- Local Subprograms --
-----------------------
@ -71,7 +67,7 @@ package body Ada.Task_Identification is
-- "=" --
---------
function "=" (Left, Right : Task_Id) return Boolean is
function "=" (Left, Right : Task_Id) return Boolean is
begin
return System.Tasking."=" (Convert_Ids (Left), Convert_Ids (Right));
end "=";
@ -139,11 +135,28 @@ package body Ada.Task_Identification is
-----------------
function Is_Callable (T : Task_Id) return Boolean is
Result : Boolean;
Id : constant System.Tasking.Task_Id := Convert_Ids (T);
begin
if T = Null_Task_Id then
raise Program_Error;
else
return System.Tasking.Rendezvous.Callable (Convert_Ids (T));
System.Soft_Links.Abort_Defer.all;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Id);
Result := Id.Callable;
STPO.Unlock (Id);
if Single_Lock then
STPO.Unlock_RTS;
end if;
System.Soft_Links.Abort_Undefer.all;
return Result;
end if;
end Is_Callable;
@ -152,11 +165,31 @@ package body Ada.Task_Identification is
-------------------
function Is_Terminated (T : Task_Id) return Boolean is
Result : Boolean;
Id : constant System.Tasking.Task_Id := Convert_Ids (T);
use System.Tasking;
begin
if T = Null_Task_Id then
raise Program_Error;
else
return System.Tasking.Stages.Terminated (Convert_Ids (T));
System.Soft_Links.Abort_Defer.all;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Id);
Result := Id.Common.State = Terminated;
STPO.Unlock (Id);
if Single_Lock then
STPO.Unlock_RTS;
end if;
System.Soft_Links.Abort_Undefer.all;
return Result;
end if;
end Is_Terminated;

24
gcc/ada/a-taside.ads
View File

@ -35,25 +35,18 @@
-- --
------------------------------------------------------------------------------
pragma Warnings (Off);
-- Allow withing of non-Preelaborated units in Ada 2005 mode where this
-- package will be categorized as Preelaborate. See AI-362 for details.
-- It is safe in the context of the run-time to violate the rules!
with System;
with System.Tasking;
pragma Warnings (On);
package Ada.Task_Identification is
pragma Preelaborate_05 (Task_Identification);
-- In accordance with Ada 2005 AI-362
pragma Preelaborate_05;
-- In accordance with Ada 2005 AI-362
type Task_Id is private;
Null_Task_Id : constant Task_Id;
function "=" (Left, Right : Task_Id) return Boolean;
function "=" (Left, Right : Task_Id) return Boolean;
pragma Inline ("=");
function Image (T : Task_Id) return String;
@ -63,7 +56,7 @@ pragma Preelaborate_05 (Task_Identification);
procedure Abort_Task (T : Task_Id);
pragma Inline (Abort_Task);
-- Note: parameter is mode IN, not IN OUT, per AI-00101.
-- Note: parameter is mode IN, not IN OUT, per AI-00101
function Is_Terminated (T : Task_Id) return Boolean;
pragma Inline (Is_Terminated);
@ -75,13 +68,6 @@ private
type Task_Id is new System.Tasking.Task_Id;
pragma Warnings (Off);
-- Allow non-static constant in Ada 2005 mode where this package will be
-- categorized as Preelaborate. See AI-362 for details. It is safe in the
-- context of the run-time to violate the rules!
Null_Task_Id : constant Task_Id := Task_Id (System.Tasking.Null_Task);
pragma Warnings (On);
Null_Task_Id : constant Task_Id := null;
end Ada.Task_Identification;

7
gcc/ada/g-os_lib.adb
View File

@ -65,11 +65,14 @@ package body GNAT.OS_Lib is
-- The following are used by Create_Temp_File
Current_Temp_File_Name : String := "GNAT-TEMP-000000.TMP";
First_Temp_File_Name : constant String := "GNAT-TEMP-000000.TMP";
-- Used to initialize Current_Temp_File_Name and Temp_File_Name_Last_Digit
Current_Temp_File_Name : String := First_Temp_File_Name;
-- Name of the temp file last created
Temp_File_Name_Last_Digit : constant Positive :=
Current_Temp_File_Name'Last - 4;
First_Temp_File_Name'Last - 4;
-- Position of the last digit in Current_Temp_File_Name
Max_Attempts : constant := 100;

3
gcc/ada/g-string.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1995-2002 Free Software Foundation, Inc. --
-- Copyright (C) 1995-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- --
@ -36,6 +36,7 @@
with Unchecked_Deallocation;
package GNAT.Strings is
pragma Preelaborate;
type String_Access is access all String;
-- General purpose string access type. Note that the caller is

4
gcc/ada/s-auxdec-vms_64.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- 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- --
@ -42,7 +42,7 @@
with Unchecked_Conversion;
package System.Aux_DEC is
pragma Elaborate_Body (Aux_DEC);
pragma Preelaborate;
subtype Short_Address is Address
range -2 ** (32 - 1) .. +2 ** (32 - 1) - 1;

4
gcc/ada/s-auxdec.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- 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- --
@ -40,7 +40,7 @@
with Unchecked_Conversion;
package System.Aux_DEC is
pragma Elaborate_Body (Aux_DEC);
pragma Preelaborate;
subtype Short_Address is Address;
-- In some versions of System.Aux_DEC, notably that for VMS on the

33
gcc/ada/s-exctab.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2003 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- --
@ -43,9 +43,9 @@ package body System.Exception_Table is
procedure Set_HT_Link (T : Exception_Data_Ptr; Next : Exception_Data_Ptr);
function Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr;
function Hash (F : Big_String_Ptr) return HTable_Headers;
function Equal (A, B : Big_String_Ptr) return Boolean;
function Get_Key (T : Exception_Data_Ptr) return Big_String_Ptr;
function Hash (F : System.Address) return HTable_Headers;
function Equal (A, B : System.Address) return Boolean;
function Get_Key (T : Exception_Data_Ptr) return System.Address;
package Exception_HTable is new System.HTable.Static_HTable (
Header_Num => HTable_Headers,
@ -54,7 +54,7 @@ package body System.Exception_Table is
Null_Ptr => null,
Set_Next => Set_HT_Link,
Next => Get_HT_Link,
Key => Big_String_Ptr,
Key => System.Address,
Get_Key => Get_Key,
Hash => Hash,
Equal => Equal);
@ -63,15 +63,17 @@ package body System.Exception_Table is
-- Equal --
-----------
function Equal (A, B : Big_String_Ptr) return Boolean is
J : Integer := 1;
function Equal (A, B : System.Address) return Boolean is
S1 : constant Big_String_Ptr := To_Ptr (A);
S2 : constant Big_String_Ptr := To_Ptr (B);
J : Integer := 1;
begin
loop
if A (J) /= B (J) then
if S1 (J) /= S2 (J) then
return False;
elsif A (J) = ASCII.NUL then
elsif S1 (J) = ASCII.NUL then
return True;
else
@ -93,7 +95,7 @@ package body System.Exception_Table is
-- Get_Key --
-------------
function Get_Key (T : Exception_Data_Ptr) return Big_String_Ptr is
function Get_Key (T : Exception_Data_Ptr) return System.Address is
begin
return T.Full_Name;
end Get_Key;
@ -125,9 +127,10 @@ package body System.Exception_Table is
-- Hash --
----------
function Hash (F : Big_String_Ptr) return HTable_Headers is
function Hash (F : System.Address) return HTable_Headers is
type S is mod 2**8;
Str : constant Big_String_Ptr := To_Ptr (F);
Size : constant S := S (HTable_Headers'Last - HTable_Headers'First + 1);
Tmp : S := 0;
J : Positive;
@ -135,10 +138,10 @@ package body System.Exception_Table is
begin
J := 1;
loop
if F (J) = ASCII.NUL then
if Str (J) = ASCII.NUL then
return HTable_Headers'First + HTable_Headers'Base (Tmp mod Size);
else
Tmp := Tmp xor S (Character'Pos (F (J)));
Tmp := Tmp xor S (Character'Pos (Str (J)));
end if;
J := J + 1;
end loop;
@ -161,7 +164,7 @@ package body System.Exception_Table is
begin
Copy (X'Range) := X;
Copy (Copy'Last) := ASCII.NUL;
Res := Exception_HTable.Get (To_Ptr (Copy'Address));
Res := Exception_HTable.Get (Copy'Address);
-- If unknown exception, create it on the heap. This is a legitimate
-- situation in the distributed case when an exception is defined only
@ -175,7 +178,7 @@ package body System.Exception_Table is
(Not_Handled_By_Others => False,
Lang => 'A',
Name_Length => Copy'Length,
Full_Name => To_Ptr (Dyn_Copy.all'Address),
Full_Name => Dyn_Copy.all'Address,
HTable_Ptr => null,
Import_Code => 0,
Raise_Hook => null);

3
gcc/ada/s-inmaop-posix.adb
View File

@ -286,13 +286,14 @@ package body System.Interrupt_Management.Operations is
end Setup_Interrupt_Mask;
begin
declare
mask : aliased sigset_t;
allmask : aliased sigset_t;
Result : Interfaces.C.int;
begin
Interrupt_Management.Initialize;
for Sig in 1 .. Signal'Last loop
Result := sigaction
(Sig, null, Initial_Action (Sig)'Unchecked_Access);

1
gcc/ada/s-inmaop-vms.adb
View File

@ -295,6 +295,7 @@ package body System.Interrupt_Management.Operations is
end Setup_Interrupt_Mask;
begin
Interrupt_Management.Initialize;
Environment_Mask := (others => False);
All_Tasks_Mask := (others => True);

9
gcc/ada/s-intman-dummy.adb
View File

@ -35,4 +35,13 @@
package body System.Interrupt_Management is
----------------
-- Initialize --
----------------
procedure Initialize is
begin
null;
end Initialize;
end System.Interrupt_Management;

41
gcc/ada/s-intman-irix-athread.adb
View File

@ -34,9 +34,6 @@
-- This is an Irix (old pthread library) version of this package.
-- PLEASE DO NOT add any dependences on other packages.
-- This package is designed to work with or without tasking support.
-- Make a careful study of all signals available under the OS,
-- to see which need to be reserved, kept always unmasked,
-- or kept always unmasked.
@ -49,6 +46,7 @@ with System.OS_Interface;
with Interfaces.C;
-- used for "int"
package body System.Interrupt_Management is
use System.OS_Interface;
@ -82,25 +80,27 @@ package body System.Interrupt_Management is
pragma Import
(C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
begin
declare
function State (Int : Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in a-init.c
-- The input argument is the interrupt number,
-- and the result is one of the following:
function State (Int : Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in a-init.c
-- The input argument is the interrupt number,
-- and the result is one of the following:
User : constant Character := 'u';
Runtime : constant Character := 'r';
Default : constant Character := 's';
-- 'n' this interrupt not set by any Interrupt_State pragma
-- 'u' Interrupt_State pragma set state to User
-- 'r' Interrupt_State pragma set state to Runtime
-- 's' Interrupt_State pragma set state to System (use "default"
-- system handler)
User : constant Character := 'u';
Runtime : constant Character := 'r';
Default : constant Character := 's';
-- 'n' this interrupt not set by any Interrupt_State pragma
-- 'u' Interrupt_State pragma set state to User
-- 'r' Interrupt_State pragma set state to Runtime
-- 's' Interrupt_State pragma set state to System (use "default"
-- system handler)
----------------
-- Initialize --
----------------
procedure Initialize is
use Interfaces.C;
begin
Abort_Task_Interrupt := Abort_Signal;
@ -158,5 +158,6 @@ begin
-- mark it as reserved.
Reserve (0) := True;
end;
end Initialize;
end System.Interrupt_Management;

47
gcc/ada/s-intman-irix.adb
View File

@ -34,9 +34,6 @@
-- This is a SGI Pthread version of this package.
-- PLEASE DO NOT add any dependences on other packages.
-- This package is designed to work with or without tasking support.
-- Make a careful study of all signals available under the OS,
-- to see which need to be reserved, kept always unmasked,
-- or kept always unmasked.
@ -63,27 +60,36 @@ package body System.Interrupt_Management is
pragma Import
(C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
use type Interfaces.C.int;
function State (Int : Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
begin
declare
function State (Int : Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in a-init.c
-- The input argument is the interrupt number,
-- and the result is one of the following:
-- Get interrupt state. Defined in a-init.c
-- The input argument is the interrupt number,
-- and the result is one of the following:
User : constant Character := 'u';
Runtime : constant Character := 'r';
Default : constant Character := 's';
-- 'n' this interrupt not set by any Interrupt_State pragma
-- 'u' Interrupt_State pragma set state to User
-- 'r' Interrupt_State pragma set state to Runtime
-- 's' Interrupt_State pragma set state to System (use "default"
-- system handler)
User : constant Character := 'u';
Runtime : constant Character := 'r';
Default : constant Character := 's';
-- 'n' this interrupt not set by any Interrupt_State pragma
-- 'u' Interrupt_State pragma set state to User
-- 'r' Interrupt_State pragma set state to Runtime
-- 's' Interrupt_State pragma set state to System (use "default"
-- system handler)
----------------
-- Initialize --
----------------
Initialized : Boolean := False;
procedure Initialize is
use type Interfaces.C.int;
begin
if Initialized then
return;
end if;
Initialized := True;
Abort_Task_Interrupt := SIGABRT;
-- Change this if you want to use another signal for task abort.
@ -137,5 +143,6 @@ begin
-- mark it as reserved.
Reserve (0) := True;
end;
end Initialize;
end System.Interrupt_Management;

45
gcc/ada/s-intman-mingw.adb
View File

@ -33,34 +33,29 @@
-- This is the NT version of this package
-- This file performs the system-dependent translation between machine
-- exceptions and the Ada exceptions, if any, that should be raised when they
-- occur.
-- PLEASE DO NOT add any dependences on other packages.
-- This package is designed to work with or without tasking support.
-- See the other warnings in the package specification before making any
-- modifications to this file.
-- Make a careful study of all signals available under the OS, to see which
-- need to be reserved, kept always unmasked, or kept always unmasked. Be on
-- the lookout for special signals that may be used by the thread library.
with System.OS_Interface; use System.OS_Interface;
package body System.Interrupt_Management is
begin
-- "Reserve" all the interrupts, except those that are explicitely defined
for J in Interrupt_ID'Range loop
Reserve (J) := True;
end loop;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
-- "Reserve" all the interrupts, except those that are explicitely
-- defined.
for J in Interrupt_ID'Range loop
Reserve (J) := True;
end loop;
Reserve (SIGINT) := False;
Reserve (SIGILL) := False;
Reserve (SIGABRT) := False;
Reserve (SIGFPE) := False;
Reserve (SIGSEGV) := False;
Reserve (SIGTERM) := False;
end Initialize;
Reserve (SIGINT) := False;
Reserve (SIGILL) := False;
Reserve (SIGABRT) := False;
Reserve (SIGFPE) := False;
Reserve (SIGSEGV) := False;
Reserve (SIGTERM) := False;
end System.Interrupt_Management;

56
gcc/ada/s-intman-posix.adb
View File

@ -33,12 +33,6 @@
-- This is the POSIX threads version of this package
-- PLEASE DO NOT add any dependences on other packages. ??? why not ???
-- This package is designed to work with or without tasking support.
-- See the other warnings in the package specification before making
-- any modifications to this file.
-- Make a careful study of all signals available under the OS, to see which
-- need to be reserved, kept always unmasked, or kept always unmasked. Be on
-- the lookout for special signals that may be used by the thread library.
@ -88,6 +82,21 @@ package body System.Interrupt_Management is
-- Local Subprograms --
-----------------------
function State (Int : Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in init.c
-- The input argument is the interrupt number,
-- and the result is one of the following:
User : constant Character := 'u';
Runtime : constant Character := 'r';
Default : constant Character := 's';
-- 'n' this interrupt not set by any Interrupt_State pragma
-- 'u' Interrupt_State pragma set state to User
-- 'r' Interrupt_State pragma set state to Runtime
-- 's' Interrupt_State pragma set state to System (use "default"
-- system handler)
procedure Notify_Exception
(signo : Signal;
siginfo : System.Address;
@ -154,32 +163,24 @@ package body System.Interrupt_Management is
end case;
end Notify_Exception;
-------------------------
-- Package Elaboration --
-------------------------
----------------
-- Initialize --
----------------
begin
declare
Initialized : Boolean := False;
procedure Initialize is
act : aliased struct_sigaction;
old_act : aliased struct_sigaction;
Result : System.OS_Interface.int;
function State (Int : Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in a-init.c
-- The input argument is the interrupt number,
-- and the result is one of the following:
User : constant Character := 'u';
Runtime : constant Character := 'r';
Default : constant Character := 's';
-- 'n' this interrupt not set by any Interrupt_State pragma
-- 'u' Interrupt_State pragma set state to User
-- 'r' Interrupt_State pragma set state to Runtime
-- 's' Interrupt_State pragma set state to System (use "default"
-- system handler)
begin
if Initialized then
return;
end if;
Initialized := True;
-- Need to call pthread_init very early because it is doing signal
-- initializations.
@ -295,5 +296,6 @@ begin
-- mark it as reserved.
Reserve (0) := True;
end;
end Initialize;
end System.Interrupt_Management;

56
gcc/ada/s-intman-solaris.adb
View File

@ -33,9 +33,6 @@
-- This is a Solaris version of this package.
-- PLEASE DO NOT add any dependences on other packages.
-- This package is designed to work with or without tasking support.
-- Make a careful study of all signals available under the OS,
-- to see which need to be reserved, kept always unmasked,
-- or kept always unmasked.
@ -63,6 +60,21 @@ package body System.Interrupt_Management is
pragma Import
(C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
function State (Int : Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in init.c
-- The input argument is the interrupt number,
-- and the result is one of the following:
User : constant Character := 'u';
Runtime : constant Character := 'r';
Default : constant Character := 's';
-- 'n' this interrupt not set by any Interrupt_State pragma
-- 'u' Interrupt_State pragma set state to User
-- 'r' Interrupt_State pragma set state to Runtime
-- 's' Interrupt_State pragma set state to System (use "default"
-- system handler)
----------------------
-- Notify_Exception --
----------------------
@ -86,8 +98,7 @@ package body System.Interrupt_Management is
info : access siginfo_t;
context : access ucontext_t)
is
pragma Warnings (Off, context);
pragma Unreferenced (context);
begin
-- Check that treatment of exception propagation here
-- is consistent with treatment of the abort signal in
@ -121,33 +132,25 @@ package body System.Interrupt_Management is
end case;
end Notify_Exception;
----------------------------
-- Package Initialization --
----------------------------
----------------
-- Initialize --
----------------
begin
declare
Initialized : Boolean := False;
procedure Initialize is
act : aliased struct_sigaction;
old_act : aliased struct_sigaction;
mask : aliased sigset_t;
Result : Interfaces.C.int;
function State (Int : Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in a-init.c
-- The input argument is the interrupt number,
-- and the result is one of the following:
--
User : constant Character := 'u';
Runtime : constant Character := 'r';
Default : constant Character := 's';
-- 'n' this interrupt not set by any Interrupt_State pragma
-- 'u' Interrupt_State pragma set state to User
-- 'r' Interrupt_State pragma set state to Runtime
-- 's' Interrupt_State pragma set state to System (use "default"
-- system handler)
begin
if Initialized then
return;
end if;
Initialized := True;
-- Need to call pthread_init very early because it is doing signal
-- initializations.
@ -248,5 +251,6 @@ begin
-- mark it as reserved.
Reserve (0) := True;
end;
end Initialize;
end System.Interrupt_Management;

34
gcc/ada/s-intman-vms.adb
View File

@ -38,20 +38,29 @@ with System.OS_Interface;
package body System.Interrupt_Management is
use System.OS_Interface;
use type unsigned_long;
----------------
-- Initialize --
----------------
begin
Abort_Task_Interrupt := Interrupt_ID_0;
-- Unused
Initialized : Boolean := False;
Reserve := Reserve or Keep_Unmasked or Keep_Masked;
Reserve (Interrupt_ID_0) := True;
declare
procedure Initialize is
use System.OS_Interface;
use type unsigned_long;
Status : Cond_Value_Type;
begin
if Initialized then
return;
end if;
Initialized := True;
Abort_Task_Interrupt := Interrupt_ID_0;
-- Unused
Reserve := Reserve or Keep_Unmasked or Keep_Masked;
Reserve (Interrupt_ID_0) := True;
Sys_Crembx
(Status => Status,
Prmflg => False,
@ -60,7 +69,6 @@ begin
Bufquo => Interrupt_Bufquo,
Lognam => "GNAT_Interrupt_Mailbox",
Flags => CMB_M_READONLY);
pragma Assert ((Status and 1) = 1);
Sys_Assign
@ -68,7 +76,7 @@ begin
Devnam => "GNAT_Interrupt_Mailbox",
Chan => Snd_Interrupt_Chan,
Flags => AGN_M_WRITEONLY);
pragma Assert ((Status and 1) = 1);
end;
end Initialize;
end System.Interrupt_Management;

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

@ -39,16 +39,6 @@
-- 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
-- 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.
@ -62,8 +52,7 @@ with System.OS_Interface;
-- sigset_t
package System.Interrupt_Management is
pragma Elaborate_Body;
pragma Preelaborate;
type Interrupt_Mask is limited private;
@ -110,6 +99,11 @@ package System.Interrupt_Management is
-- 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;
-- Initialize the various variables defined in this package.
-- This procedure must be called before accessing any object from this
-- package and can be called multiple times.
private
use type System.OS_Interface.unsigned_long;

56
gcc/ada/s-intman-vxworks.adb
View File

@ -33,15 +33,6 @@
-- This is the VxWorks version of this package.
-- It is likely to need tailoring to fit each operating system
-- and machine architecture.
-- PLEASE DO NOT add any dependences on other packages.
-- This package is designed to work with or without tasking support.
-- See the other warnings in the package specification before making
-- any modifications to this file.
-- Make a careful study of all signals available under the OS,
-- to see which need to be reserved, kept always unmasked,
-- or kept always unmasked.
@ -74,6 +65,20 @@ package body System.Interrupt_Management is
-- Local Subprograms --
-----------------------
function State (Int : Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in init.c
-- The input argument is the interrupt number,
-- and the result is one of the following:
Runtime : constant Character := 'r';
Default : constant Character := 's';
-- 'n' this interrupt not set by any Interrupt_State pragma
-- 'u' Interrupt_State pragma set state to User
-- 'r' Interrupt_State pragma set state to Runtime
-- 's' Interrupt_State pragma set state to System (use "default"
-- system handler)
procedure Notify_Exception (signo : Signal);
-- Identify the Ada exception to be raised using
-- the information when the system received a synchronous signal.
@ -116,27 +121,21 @@ package body System.Interrupt_Management is
end loop;
end Initialize_Interrupts;
begin
declare
----------------
-- Initialize --
----------------
Initialized : Boolean := False;
procedure Initialize is
mask : aliased sigset_t;
Result : int;
function State (Int : Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in a-init.c
-- The input argument is the interrupt number,
-- and the result is one of the following:
Runtime : constant Character := 'r';
Default : constant Character := 's';
-- 'n' this interrupt not set by any Interrupt_State pragma
-- 'u' Interrupt_State pragma set state to User
-- 'r' Interrupt_State pragma set state to Runtime
-- 's' Interrupt_State pragma set state to System (use "default"
-- system handler)
begin
-- Initialize signal handling
if Initialized then
return;
end if;
Initialized := True;
-- Change this if you want to use another signal for task abort.
-- SIGTERM might be a good one.
@ -176,5 +175,6 @@ begin
-- The abort signal must also be unmasked
Keep_Unmasked (Abort_Task_Signal) := True;
end;
end Initialize;
end System.Interrupt_Management;

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

@ -40,13 +40,6 @@
-- 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.
-- 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
@ -61,8 +54,7 @@ with Interfaces.C;
-- used for int
package System.Interrupt_Management is
pragma Elaborate_Body;
pragma Preelaborate;
type Interrupt_Mask is limited private;
@ -114,6 +106,11 @@ package System.Interrupt_Management is
-- This procedure is used to initialize signal-to-exception mapping in
-- each task.
procedure Initialize;
-- Initialize the various variables defined in this package.
-- This procedure must be called before accessing any object from this
-- package and can be called multiple times.
private
type Interrupt_Mask is new System.OS_Interface.sigset_t;
-- In some implementation Interrupt_Mask can be represented as a linked

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

@ -38,13 +38,6 @@
-- 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.
-- 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
@ -59,8 +52,7 @@ with Interfaces.C;
-- used for int
package System.Interrupt_Management is
pragma Elaborate_Body;
pragma Preelaborate;
type Interrupt_Mask is limited private;
@ -103,6 +95,11 @@ package System.Interrupt_Management is
-- example, it may be mapped to an exception used to implement task abort,
-- or used to implement time delays.
procedure Initialize;
-- Initialize the various variables defined in this package.
-- This procedure must be called before accessing any object from this
-- package, and can be called multiple times.
private
type Interrupt_Mask is new System.OS_Interface.sigset_t;
-- In some implementations Interrupt_Mask can be represented as a linked

40
gcc/ada/s-osprim-mingw.adb
View File

@ -33,7 +33,6 @@
-- This is the NT version of this package
with Ada.Exceptions;
with Interfaces.C;
package body System.OS_Primitives is
@ -267,20 +266,35 @@ package body System.OS_Primitives is
end if;
end Timed_Delay;
-- Package elaboration, get starting time as base
----------------
-- Initialize --
----------------
begin
if not QueryPerformanceFrequency (Tick_Frequency'Access) then
Ada.Exceptions.Raise_Exception
(Program_Error'Identity,
"cannot get high performance counter frequency");
end if;
Initialized : Boolean := False;
Get_Base_Time;
procedure Initialize is
begin
if Initialized then
return;
end if;
-- Keep base clock and ticks for the monotonic clock. These values should
-- never be changed to ensure proper behavior of the monotonic clock.
Initialized := True;
-- Get starting time as base
if not QueryPerformanceFrequency (Tick_Frequency'Access) then
raise Program_Error
with "cannot get high performance counter frequency";
end if;
Get_Base_Time;
-- Keep base clock and ticks for the monotonic clock. These values
-- should never be changed to ensure proper behavior of the monotonic
-- clock.
Base_Monotonic_Clock := Base_Clock;
Base_Monotonic_Ticks := Base_Ticks;
end Initialize;
Base_Monotonic_Clock := Base_Clock;
Base_Monotonic_Ticks := Base_Ticks;
end System.OS_Primitives;

16
gcc/ada/s-osprim-os2.adb
View File

@ -167,6 +167,18 @@ package body System.OS_Primitives is
end if;
end Timed_Delay;
begin
Set_Epoch_Offset;
----------------
-- Initialize --
----------------
Initialized : Boolean := False;
procedure Initialize is
begin
if not Initialized then
Initialized := True;
Set_Epoch_Offset;
end if;
end Initialize;
end System.OS_Primitives;

9
gcc/ada/s-osprim-posix.adb
View File

@ -156,4 +156,13 @@ package body System.OS_Primitives is
end if;
end Timed_Delay;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
null;
end Initialize;
end System.OS_Primitives;

9
gcc/ada/s-osprim-solaris.adb
View File

@ -121,4 +121,13 @@ package body System.OS_Primitives is
end if;
end Timed_Delay;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
null;
end Initialize;
end System.OS_Primitives;

9
gcc/ada/s-osprim-unix.adb
View File

@ -121,4 +121,13 @@ package body System.OS_Primitives is
end if;
end Timed_Delay;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
null;
end Initialize;
end System.OS_Primitives;

14
gcc/ada/s-osprim-vms.adb
View File

@ -45,14 +45,22 @@ package body System.OS_Primitives is
pragma Import (C, Get_GMToff, "get_gmtoff");
-- Get the offset from GMT for this timezone
VMS_Epoch_Offset : constant Long_Integer :=
10_000_000 *
(3_506_716_800 + Long_Integer (Get_GMToff));
function VMS_Epoch_Offset return Long_Integer;
pragma Inline (VMS_Epoch_Offset);
-- The offset between the Unix Epoch and the VMS Epoch
subtype Cond_Value_Type is System.Aux_DEC.Unsigned_Longword;
-- Condition Value return type
----------------------
-- VMS_Epoch_Offset --
----------------------
function VMS_Epoch_Offset return Long_Integer is
begin
return 10_000_000 * (3_506_716_800 + Long_Integer (Get_GMToff));
end VMS_Epoch_Offset;
----------------
-- Sys_Schdwk --
----------------

3
gcc/ada/s-osprim-vms.ads
View File

@ -35,11 +35,12 @@
-- delays in non tasking applications on Alpha/VMS
-- The choice of the real clock/delay implementation (depending on whether
-- tasking is involved or not) is done via soft links (see s-tasoli.ads)
-- tasking is involved or not) is done via soft links (see s-soflin.ads)
-- NEVER add any dependency to tasking packages here
package System.OS_Primitives is
pragma Preelaborate;
subtype OS_Time is Long_Integer;
-- System time on VMS is used for performance reasons.

9
gcc/ada/s-osprim-vxworks.adb
View File

@ -158,4 +158,13 @@ package body System.OS_Primitives is
end if;
end Timed_Delay;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
null;
end Initialize;
end System.OS_Primitives;

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

@ -35,11 +35,12 @@
-- delays in non tasking applications.
-- The choice of the real clock/delay implementation (depending on whether
-- tasking is involved or not) is done via soft links (see s-tasoli.ads)
-- tasking is involved or not) is done via soft links (see s-soflin.ads)
-- NEVER add any dependency to tasking packages here
package System.OS_Primitives is
pragma Preelaborate;
Max_Sensible_Delay : constant Duration :=
Duration'Min (183 * 24 * 60 * 60.0,
@ -53,6 +54,11 @@ package System.OS_Primitives is
-- occurs in high integrity mode with 32-bit words, and possibly on
-- some specific ports of GNAT), Duration'Last is used instead.
procedure Initialize;
-- Initialize global settings related to this package.
-- This procedure should be called before any other subprograms in
-- this package. Note that this procedure can be called several times.
function Clock return Duration;
pragma Inline (Clock);
-- Returns "absolute" time, represented as an offset

4
gcc/ada/s-proinf-irix-athread.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1997-1999 Free Software Foundation, Inc. --
-- Copyright (C) 1997-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- --
@ -46,7 +46,9 @@
-- then relink your application as usual.
--
pragma Warnings (Off);
with GNAT.OS_Lib;
pragma Warnings (On);
package body System.Program_Info is

31
gcc/ada/s-proinf-irix-athread.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1997-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1997-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,62 +35,45 @@
-- to the run-time system at program startup for the SGI implementation.
package System.Program_Info is
pragma Preelaborate;
function Initial_Sproc_Count return Integer;
--
-- The number of sproc created at program startup for scheduling
-- threads.
--
function Max_Sproc_Count return Integer;
--
function Max_Sproc_Count return Integer;
-- The maximum number of sprocs that can be created by the program
-- for servicing threads. This limit includes both the pre-created
-- sprocs and those explicitly created under program control.
--
function Sproc_Stack_Size return Integer;
--
function Sproc_Stack_Size return Integer;
-- The size, in bytes, of the sproc's initial stack.
--
function Default_Time_Slice return Duration;
--
-- The default time quanta for round-robin scheduling of threads of
-- equal priority. This default value can be overridden on a per-task
-- basis by specifying an alternate value via the implementation-defined
-- Task_Info pragma. See s-tasinf.ads for more information.
--
function Default_Task_Stack return Integer;
--
function Default_Task_Stack return Integer;
-- The default stack size for each created thread. This default value
-- can be overriden on a per-task basis by the language-defined
-- Storage_Size pragma.
--
function Stack_Guard_Pages return Integer;
--
function Stack_Guard_Pages return Integer;
-- The number of non-writable, guard pages to append to the bottom of
-- each thread's stack.
--
function Pthread_Sched_Signal return Integer;
--
-- The signal used by the Pthreads library to affect scheduling actions
-- in remote sprocs.
--
function Pthread_Arena_Size return Integer;
--
function Pthread_Arena_Size return Integer;
-- The size of the shared arena from which pthread locks are allocated.
-- See the usinit(3p) man page for more information on shared arenas.
--
function Os_Default_Priority return Integer;
--
-- The default Irix Non-Degrading priority for each sproc created to
-- service threads.
--
end System.Program_Info;

3
gcc/ada/s-proinf.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1996-2003 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- --
@ -35,6 +35,7 @@
-- to the run-time system at program startup.
package System.Program_Info is
pragma Preelaborate;
function Default_Task_Stack return Integer;
-- The default stack size for each created thread. This default value

91
gcc/ada/s-soflin.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2001 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- --
@ -35,26 +35,26 @@ pragma Polling (Off);
-- We must turn polling off for this unit, because otherwise we get
-- an infinite loop from the code within the Poll routine itself.
with System.Machine_State_Operations; use System.Machine_State_Operations;
-- Used for Create_TSD, Destroy_TSD
with System.Parameters;
-- Used for Sec_Stack_Ratio
pragma Warnings (Off);
-- Disable warnings since System.Secondary_Stack is currently not
-- Preelaborate
with System.Secondary_Stack;
pragma Warnings (On);
package body System.Soft_Links is
package SST renames System.Secondary_Stack;
-- Allocate an exception stack for the main program to use.
-- We make sure that the stack has maximum alignment. Some systems require
-- this (e.g. Sun), and in any case it is a good idea for efficiency.
NT_Exc_Stack : array (0 .. 8192) of aliased Character;
for NT_Exc_Stack'Alignment use Standard'Maximum_Alignment;
-- Allocate an exception stack for the main program to use.
-- This is currently only used under VMS.
NT_TSD : TSD;
-- Note: we rely on the default initialization of NT_TSD.
--------------------
-- Abort_Defer_NT --
@ -116,10 +116,6 @@ package body System.Soft_Links is
SST.SS_Init
(New_TSD.Sec_Stack_Addr, SST.Default_Secondary_Stack_Size);
end if;
New_TSD.Machine_State_Addr :=
System.Address
(System.Machine_State_Operations.Allocate_Machine_State);
end Create_TSD;
-----------------------
@ -138,8 +134,6 @@ package body System.Soft_Links is
procedure Destroy_TSD (Old_TSD : in out TSD) is
begin
SST.SS_Free (Old_TSD.Sec_Stack_Addr);
System.Machine_State_Operations.Free_Machine_State
(Machine_State (Old_TSD.Machine_State_Addr));
end Destroy_TSD;
---------------------
@ -166,14 +160,14 @@ package body System.Soft_Links is
function Get_Exc_Stack_Addr_NT return Address is
begin
return NT_TSD.Exc_Stack_Addr;
return NT_Exc_Stack (NT_Exc_Stack'Last)'Address;
end Get_Exc_Stack_Addr_NT;
-----------------------------
-- Get_Exc_Stack_Addr_Soft --
-----------------------------
function Get_Exc_Stack_Addr_Soft return Address is
function Get_Exc_Stack_Addr_Soft return Address is
begin
return Get_Exc_Stack_Addr.all;
end Get_Exc_Stack_Addr_Soft;
@ -205,24 +199,6 @@ package body System.Soft_Links is
return Get_Jmpbuf_Address.all;
end Get_Jmpbuf_Address_Soft;
-------------------------------
-- Get_Machine_State_Addr_NT --
-------------------------------
function Get_Machine_State_Addr_NT return Address is
begin
return NT_TSD.Machine_State_Addr;
end Get_Machine_State_Addr_NT;
---------------------------------
-- Get_Machine_State_Addr_Soft --
---------------------------------
function Get_Machine_State_Addr_Soft return Address is
begin
return Get_Machine_State_Addr.all;
end Get_Machine_State_Addr_Soft;
---------------------------
-- Get_Sec_Stack_Addr_NT --
---------------------------
@ -259,26 +235,6 @@ package body System.Soft_Links is
null;
end Null_Adafinal;
---------------------------
-- Set_Exc_Stack_Addr_NT --
---------------------------
procedure Set_Exc_Stack_Addr_NT (Self_ID : Address; Addr : Address) is
pragma Warnings (Off, Self_ID);
begin
NT_TSD.Exc_Stack_Addr := Addr;
end Set_Exc_Stack_Addr_NT;
-----------------------------
-- Set_Exc_Stack_Addr_Soft --
-----------------------------
procedure Set_Exc_Stack_Addr_Soft (Self_ID : Address; Addr : Address) is
begin
Set_Exc_Stack_Addr (Self_ID, Addr);
end Set_Exc_Stack_Addr_Soft;
---------------------------
-- Set_Jmpbuf_Address_NT --
---------------------------
@ -293,24 +249,6 @@ package body System.Soft_Links is
Set_Jmpbuf_Address (Addr);
end Set_Jmpbuf_Address_Soft;
-------------------------------
-- Set_Machine_State_Addr_NT --
-------------------------------
procedure Set_Machine_State_Addr_NT (Addr : Address) is
begin
NT_TSD.Machine_State_Addr := Addr;
end Set_Machine_State_Addr_NT;
---------------------------------
-- Set_Machine_State_Addr_Soft --
---------------------------------
procedure Set_Machine_State_Addr_Soft (Addr : Address) is
begin
Set_Machine_State_Addr (Addr);
end Set_Machine_State_Addr_Soft;
---------------------------
-- Set_Sec_Stack_Addr_NT --
---------------------------
@ -365,13 +303,4 @@ package body System.Soft_Links is
return "main_task";
end Task_Name_NT;
-------------------------
-- Package Elaboration --
-------------------------
begin
NT_TSD.Exc_Stack_Addr := NT_Exc_Stack (8192)'Address;
Ada.Exceptions.Save_Occurrence
(NT_TSD.Current_Excep, Ada.Exceptions.Null_Occurrence);
end System.Soft_Links;

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

@ -32,7 +32,7 @@
------------------------------------------------------------------------------
-- This package contains a set of subprogram access variables that access
-- some low-level primitives that are called different depending wether
-- some low-level primitives that are called different depending whether
-- tasking is involved or not (e.g. the Get/Set_Jmpbuf_Address that needs
-- to provide a different value for each task). To avoid dragging in the
-- tasking all the time, we use a system of soft links where the links are
@ -43,7 +43,9 @@ with Ada.Exceptions;
with System.Stack_Checking;
package System.Soft_Links is
pragma Elaborate_Body;
pragma Warnings (Off);
pragma Preelaborate_05;
pragma Warnings (On);
subtype EOA is Ada.Exceptions.Exception_Occurrence_Access;
subtype EO is Ada.Exceptions.Exception_Occurrence;
@ -210,21 +212,8 @@ package System.Soft_Links is
Get_Sec_Stack_Addr : Get_Address_Call := Get_Sec_Stack_Addr_NT'Access;
Set_Sec_Stack_Addr : Set_Address_Call := Set_Sec_Stack_Addr_NT'Access;
function Get_Machine_State_Addr_NT return Address;
procedure Set_Machine_State_Addr_NT (Addr : Address);
Get_Machine_State_Addr : Get_Address_Call
:= Get_Machine_State_Addr_NT'Access;
Set_Machine_State_Addr : Set_Address_Call
:= Set_Machine_State_Addr_NT'Access;
function Get_Exc_Stack_Addr_NT return Address;
procedure Set_Exc_Stack_Addr_NT (Self_ID : Address; Addr : Address);
-- Self_ID is a Task_Id, but in the non-tasking case there is no
-- Task_Id type available, so make do with Address.
function Get_Exc_Stack_Addr_NT return Address;
Get_Exc_Stack_Addr : Get_Address_Call := Get_Exc_Stack_Addr_NT'Access;
Set_Exc_Stack_Addr : Set_Address_Call2 := Set_Exc_Stack_Addr_NT'Access;
function Get_Current_Excep_NT return EOA;
@ -302,24 +291,18 @@ package System.Soft_Links is
-- to the tasks requested stack size before the task can do
-- its first stack check.
Jmpbuf_Address : Address := Null_Address;
pragma Warnings (Off);
Jmpbuf_Address : System.Address := System.Null_Address;
-- Address of jump buffer used to store the address of the
-- current longjmp/setjmp buffer for exception management.
-- These buffers are threaded into a stack, and the address
-- here is the top of the stack. A null address means that
-- no exception handler is currently active.
Sec_Stack_Addr : Address := Null_Address;
Sec_Stack_Addr : System.Address := System.Null_Address;
pragma Warnings (On);
-- Address of currently allocated secondary stack
Exc_Stack_Addr : Address := Null_Address;
-- Address of a task-specific stack used for the propagation of
-- exceptions in response to synchronous faults. This alternate
-- stack is necessary when propagating Storage_Error resulting
-- from a stack overflow, as the task's primary stack is full.
-- This is currently only used on the SGI, and this value stays
-- null on other platforms.
Current_Excep : aliased EO;
-- Exception occurrence that contains the information for the
-- current exception. Note that any exception in the same task
@ -328,9 +311,6 @@ package System.Soft_Links is
--
-- Also act as a list of the active exceptions in the case of the GCC
-- exception mechanism, organized as a stack with the most recent first.
Machine_State_Addr : Address := Null_Address;
-- Machine state address. Used by front-end zero cost exception
end record;
procedure Create_TSD (New_TSD : in out TSD);
@ -340,7 +320,7 @@ package System.Soft_Links is
procedure Destroy_TSD (Old_TSD : in out TSD);
pragma Inline (Destroy_TSD);
-- Called from s-tassta just before a thread is destroyed to perform
-- Called from s-tassta just before a thread is destroyed to perform
-- any required finalization.
function Get_GNAT_Exception return Ada.Exceptions.Exception_Id;
@ -364,14 +344,6 @@ package System.Soft_Links is
pragma Inline (Get_Sec_Stack_Addr_Soft);
pragma Inline (Set_Sec_Stack_Addr_Soft);
function Get_Exc_Stack_Addr_Soft return Address;
procedure Set_Exc_Stack_Addr_Soft (Self_ID : Address; Addr : Address);
pragma Inline (Get_Exc_Stack_Addr_Soft);
pragma Inline (Set_Exc_Stack_Addr_Soft);
function Get_Machine_State_Addr_Soft return Address;
procedure Set_Machine_State_Addr_Soft (Addr : Address);
pragma Inline (Get_Machine_State_Addr_Soft);
pragma Inline (Set_Machine_State_Addr_Soft);
function Get_Exc_Stack_Addr_Soft return Address;
end System.Soft_Links;

28
gcc/ada/s-solita.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004, Free Software Foundation, Inc. --
-- Copyright (C) 2004-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- --
@ -47,9 +47,6 @@ with System.Task_Primitives.Operations;
with System.Tasking;
-- Used for Task_Id
with Ada.Exceptions;
-- Used for Raise_Exception
package body System.Soft_Links.Tasking is
package STPO renames System.Task_Primitives.Operations;
@ -75,10 +72,6 @@ package body System.Soft_Links.Tasking is
procedure Set_Sec_Stack_Addr (Addr : Address);
-- Get/Set location of current task's secondary stack
function Get_Machine_State_Addr return Address;
procedure Set_Machine_State_Addr (Addr : Address);
-- Get/Set the address for storing the current task's machine state
function Get_Current_Excep return SSL.EOA;
-- Task-safe version of SSL.Get_Current_Excep
@ -99,11 +92,6 @@ package body System.Soft_Links.Tasking is
return STPO.Self.Common.Compiler_Data.Jmpbuf_Address;
end Get_Jmpbuf_Address;
function Get_Machine_State_Addr return Address is
begin
return STPO.Self.Common.Compiler_Data.Machine_State_Addr;
end Get_Machine_State_Addr;
function Get_Sec_Stack_Addr return Address is
begin
return STPO.Self.Common.Compiler_Data.Sec_Stack_Addr;
@ -118,11 +106,6 @@ package body System.Soft_Links.Tasking is
STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr;
end Set_Jmpbuf_Address;
procedure Set_Machine_State_Addr (Addr : Address) is
begin
STPO.Self.Common.Compiler_Data.Machine_State_Addr := Addr;
end Set_Machine_State_Addr;
procedure Set_Sec_Stack_Addr (Addr : Address) is
begin
STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr;
@ -143,12 +126,12 @@ package body System.Soft_Links.Tasking is
if System.Tasking.Detect_Blocking
and then Self_Id.Common.Protected_Action_Nesting > 0
then
Ada.Exceptions.Raise_Exception
(Program_Error'Identity, "potentially blocking operation");
raise Program_Error with "potentially blocking operation";
else
Abort_Defer.all;
STPO.Timed_Delay (Self_Id, Time, Mode);
Abort_Undefer.all;
end if;
end Timed_Delay_T;
-----------------------------
@ -172,8 +155,6 @@ package body System.Soft_Links.Tasking is
SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access;
SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
SSL.Get_Machine_State_Addr := Get_Machine_State_Addr'Access;
SSL.Set_Machine_State_Addr := Set_Machine_State_Addr'Access;
SSL.Get_Current_Excep := Get_Current_Excep'Access;
SSL.Timed_Delay := Timed_Delay_T'Access;
@ -182,7 +163,6 @@ package body System.Soft_Links.Tasking is
SSL.Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT);
SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT);
SSL.Set_Machine_State_Addr (SSL.Get_Machine_State_Addr_NT);
end if;
end Init_Tasking_Soft_Links;

2
gcc/ada/s-stache.ads
View File

@ -40,7 +40,7 @@
with System.Storage_Elements;
package System.Stack_Checking is
pragma Preelaborate;
pragma Elaborate_Body;
-- This unit has a junk null body. The reason is that historically we
-- used to have a real body, and it causes bootstrapping path problems

26
gcc/ada/s-stalib.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- --
@ -54,11 +54,9 @@ with System;
with Unchecked_Conversion;
package System.Standard_Library is
pragma Suppress (All_Checks);
-- Suppress explicitely all the checks to work around the Solaris linker
-- bug when using gnatmake -f -a (but without -gnatp). This is not needed
-- with Solaris 2.6, so eventually can be removed ???
pragma Warnings (Off);
pragma Preelaborate_05;
pragma Warnings (On);
type Big_String_Ptr is access all String (Positive);
-- A non-fat pointer type for null terminated strings
@ -137,8 +135,9 @@ package System.Standard_Library is
Name_Length : Natural;
-- Length of fully expanded name of exception
Full_Name : Big_String_Ptr;
Full_Name : System.Address;
-- Fully expanded name of exception, null terminated
-- You can use To_Ptr to convert this to a string.
HTable_Ptr : Exception_Data_Ptr;
-- Hash table pointer used to link entries together in the hash table
@ -157,7 +156,6 @@ package System.Standard_Library is
-- whenever the exception is raised. This call occurs immediately,
-- before any other actions taken by the raise (and in particular
-- before any unwinding of the stack occurs).
end record;
-- Definitions for standard predefined exceptions defined in Standard,
@ -179,7 +177,7 @@ package System.Standard_Library is
(Not_Handled_By_Others => False,
Lang => 'A',
Name_Length => Constraint_Error_Name'Length,
Full_Name => To_Ptr (Constraint_Error_Name'Address),
Full_Name => Constraint_Error_Name'Address,
HTable_Ptr => null,
Import_Code => 0,
Raise_Hook => null);
@ -188,7 +186,7 @@ package System.Standard_Library is
(Not_Handled_By_Others => False,
Lang => 'A',
Name_Length => Numeric_Error_Name'Length,
Full_Name => To_Ptr (Numeric_Error_Name'Address),
Full_Name => Numeric_Error_Name'Address,
HTable_Ptr => null,
Import_Code => 0,
Raise_Hook => null);
@ -197,7 +195,7 @@ package System.Standard_Library is
(Not_Handled_By_Others => False,
Lang => 'A',
Name_Length => Program_Error_Name'Length,
Full_Name => To_Ptr (Program_Error_Name'Address),
Full_Name => Program_Error_Name'Address,
HTable_Ptr => null,
Import_Code => 0,
Raise_Hook => null);
@ -206,7 +204,7 @@ package System.Standard_Library is
(Not_Handled_By_Others => False,
Lang => 'A',
Name_Length => Storage_Error_Name'Length,
Full_Name => To_Ptr (Storage_Error_Name'Address),
Full_Name => Storage_Error_Name'Address,
HTable_Ptr => null,
Import_Code => 0,
Raise_Hook => null);
@ -215,7 +213,7 @@ package System.Standard_Library is
(Not_Handled_By_Others => False,
Lang => 'A',
Name_Length => Tasking_Error_Name'Length,
Full_Name => To_Ptr (Tasking_Error_Name'Address),
Full_Name => Tasking_Error_Name'Address,
HTable_Ptr => null,
Import_Code => 0,
Raise_Hook => null);
@ -224,7 +222,7 @@ package System.Standard_Library is
(Not_Handled_By_Others => True,
Lang => 'A',
Name_Length => Abort_Signal_Name'Length,
Full_Name => To_Ptr (Abort_Signal_Name'Address),
Full_Name => Abort_Signal_Name'Address,
HTable_Ptr => null,
Import_Code => 0,
Raise_Hook => null);

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

@ -241,7 +241,9 @@ package body System.Tasking.Protected_Objects is
end Unlock;
begin
-- Ensure that tasking soft links are set when using protected objects
-- Ensure that tasking is initialized, as well as tasking soft links
-- when using protected objects.
Tasking.Initialize;
System.Soft_Links.Tasking.Init_Tasking_Soft_Links;
end System.Tasking.Protected_Objects;

19
gcc/ada/s-taprop-dummy.adb
View File

@ -40,10 +40,6 @@ pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during
-- tasking operations. It causes infinite loops and other problems.
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_Id
with System.Error_Reporting;
-- used for Shutdown
@ -55,9 +51,6 @@ package body System.Task_Primitives.Operations is
pragma Warnings (Off);
-- Turn off warnings since so many unreferenced parameters
No_Tasking : Boolean;
-- Comment required here ???
----------------
-- Abort_Task --
----------------
@ -193,8 +186,11 @@ package body System.Task_Primitives.Operations is
----------------
procedure Initialize (Environment_Task : Task_Id) is
No_Tasking : Boolean;
begin
null;
No_Tasking :=
System.Error_Reporting.Shutdown
("Tasking not implemented on this configuration");
end Initialize;
procedure Initialize (S : in out Suspension_Object) is
@ -479,11 +475,4 @@ package body System.Task_Primitives.Operations is
null;
end Yield;
begin
-- Can't raise an exception because target independent packages try to
-- do an Abort_Defer, which gets a memory fault.
No_Tasking :=
System.Error_Reporting.Shutdown
("Tasking not implemented on this configuration");
end System.Task_Primitives.Operations;

45
gcc/ada/s-taprop-hpux-dce.adb
View File

@ -43,41 +43,32 @@ pragma Polling (Off);
with System.Tasking.Debug;
-- used for Known_Tasks
with Interfaces.C;
-- used for int
-- size_t
with System.Interrupt_Management;
-- used for Keep_Unmasked
-- Abort_Task_Interrupt
-- Interrupt_ID
pragma Warnings (Off);
with System.Interrupt_Management.Operations;
-- used for Set_Interrupt_Mask
-- All_Tasks_Mask
pragma Elaborate_All (System.Interrupt_Management.Operations);
pragma Warnings (On);
with System.OS_Primitives;
-- used for Delay_Modes
with Interfaces.C;
-- used for int
-- size_t
with System.Parameters;
-- used for Size_Type
with System.Task_Primitives.Interrupt_Operations;
-- used for Get_Interrupt_ID
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_Id
with System.Soft_Links;
-- used for Defer/Undefer_Abort
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes
with Unchecked_Conversion;
with Unchecked_Deallocation;
@ -91,7 +82,6 @@ package body System.Task_Primitives.Operations is
use System.OS_Primitives;
package PIO renames System.Task_Primitives.Interrupt_Operations;
package SSL renames System.Soft_Links;
----------------
-- Local Data --
@ -124,9 +114,6 @@ package body System.Task_Primitives.Operations is
-- is not implemented for DCE threads. The HPUX 10 port is at this
-- stage considered dead, and no further work is planned on it.
FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
-- Indicates whether FIFO_Within_Priorities is set
Foreign_Task_Elaborated : aliased Boolean := True;
-- Used to identified fake tasks (i.e., non-Ada Threads)
@ -495,11 +482,6 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int;
begin
-- The little window between deferring abort and locking Self_ID is the
-- only reason to check for pending abort and priority change below!
SSL.Abort_Defer.all;
if Single_Lock then
Lock_RTS;
end if;
@ -550,7 +532,6 @@ package body System.Task_Primitives.Operations is
end if;
Result := sched_yield;
SSL.Abort_Undefer.all;
end Timed_Delay;
---------------------
@ -632,7 +613,7 @@ package body System.Task_Primitives.Operations is
Result := pthread_setschedparam
(T.Common.LL.Thread, SCHED_RR, Param'Access);
elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
Result := pthread_setschedparam
(T.Common.LL.Thread, SCHED_FIFO, Param'Access);
@ -643,7 +624,7 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
if FIFO_Within_Priorities then
if Dispatching_Policy = 'F' then
-- Annex D requirement [RM D.2.2 par. 9]:
-- If the task drops its priority due to the loss of inherited
@ -1162,6 +1143,8 @@ package body System.Task_Primitives.Operations is
begin
Environment_Task_Id := Environment_Task;
Interrupt_Management.Initialize;
-- Initialize the lock used to synchronize chain of all ATCBs
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);

39
gcc/ada/s-taprop-irix-athread.adb
View File

@ -47,20 +47,19 @@ with Interfaces.C;
with System.Tasking.Debug;
-- used for Known_Tasks
with System.Task_Info;
with System.Interrupt_Management;
-- used for Keep_Unmasked
-- Abort_Task_Interrupt
-- Interrupt_ID
with System.OS_Primitives;
-- used for Delay_Modes
with System.Task_Info;
with System.Parameters;
-- used for Size_Type
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_Id
with System.Program_Info;
-- used for Default_Task_Stack
-- Default_Time_Slice
@ -68,17 +67,6 @@ with System.Program_Info;
-- Pthread_Sched_Signal
-- Pthread_Arena_Size
with System.Soft_Links;
-- used for Defer/Undefer_Abort
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes
with System.Storage_Elements;
-- used for To_Address
@ -94,8 +82,6 @@ package body System.Task_Primitives.Operations is
use System.Parameters;
use System.OS_Primitives;
package SSL renames System.Soft_Links;
-----------------
-- Local Data --
-----------------
@ -433,12 +419,6 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int;
begin
-- Only the little window between deferring abort and
-- locking Self_ID is the reason we need to
-- check for pending abort and priority change below!
SSL.Abort_Defer.all;
if Single_Lock then
Lock_RTS;
end if;
@ -490,7 +470,6 @@ package body System.Task_Primitives.Operations is
end if;
pthread_yield;
SSL.Abort_Undefer.all;
end Timed_Delay;
---------------------
@ -819,7 +798,7 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
end Abort_Task;
----------------
----------------
-- Initialize --
----------------
@ -1087,7 +1066,9 @@ package body System.Task_Primitives.Operations is
procedure Initialize (Environment_Task : Task_Id) is
begin
Initialize_Athread_Library;
Environment_Task_Id := Environment_Task;
Interrupt_Management.Initialize;
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-- Initialize the lock used to synchronize chain of all ATCBs.
@ -1126,8 +1107,4 @@ package body System.Task_Primitives.Operations is
end if;
end Initialize_Athread_Library;
-- Package initialization
begin
Initialize_Athread_Library;
end System.Task_Primitives.Operations;

73
gcc/ada/s-taprop-irix.adb
View File

@ -49,29 +49,20 @@ with System.Task_Info;
with System.Tasking.Debug;
-- used for Known_Tasks
with System.IO;
-- used for Put_Line
with System.Interrupt_Management;
-- used for Keep_Unmasked
-- Abort_Task_Interrupt
-- Interrupt_ID
with System.OS_Primitives;
-- used for Delay_Modes
with System.IO;
-- used for Put_Line
with System.Parameters;
-- used for Size_Type
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_Id
with System.Soft_Links;
-- used for Defer/Undefer_Abort
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
with System.Program_Info;
-- used for Default_Task_Stack
-- Default_Time_Slice
@ -82,9 +73,6 @@ with System.Program_Info;
with System.OS_Interface;
-- used for various type, constant, and operations
with System.OS_Primitives;
-- used for Delay_Modes
with Unchecked_Conversion;
with Unchecked_Deallocation;
@ -97,8 +85,6 @@ package body System.Task_Primitives.Operations is
use System.OS_Primitives;
use System.Parameters;
package SSL renames System.Soft_Links;
----------------
-- Local Data --
----------------
@ -515,12 +501,6 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int;
begin
-- The little window between deferring abort and locking Self_ID is
-- the only reason we need to check for pending abort and priority
-- change below!
SSL.Abort_Defer.all;
if Single_Lock then
Lock_RTS;
end if;
@ -565,7 +545,6 @@ package body System.Task_Primitives.Operations is
end if;
Yield;
SSL.Abort_Undefer.all;
end Timed_Delay;
---------------------
@ -1243,6 +1222,8 @@ package body System.Task_Primitives.Operations is
begin
Environment_Task_Id := Environment_Task;
Interrupt_Management.Initialize;
-- Initialize the lock used to synchronize chain of all ATCBs.
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
@ -1251,6 +1232,18 @@ package body System.Task_Primitives.Operations is
Enter_Task (Environment_Task);
-- Prepare the set of signals that should unblocked in all tasks
Result := sigemptyset (Unblocked_Signal_Mask'Access);
pragma Assert (Result = 0);
for J in Interrupt_Management.Interrupt_ID loop
if System.Interrupt_Management.Keep_Unmasked (J) then
Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
pragma Assert (Result = 0);
end if;
end loop;
-- Install the abort-signal handler
if State (System.Interrupt_Management.Abort_Task_Interrupt)
@ -1272,30 +1265,4 @@ package body System.Task_Primitives.Operations is
end if;
end Initialize;
begin
declare
Result : Interfaces.C.int;
begin
-- Prepare the set of signals that should unblocked in all tasks
Result := sigemptyset (Unblocked_Signal_Mask'Access);
pragma Assert (Result = 0);
for J in Interrupt_Management.Interrupt_ID loop
if System.Interrupt_Management.Keep_Unmasked (J) then
Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
pragma Assert (Result = 0);
end if;
end loop;
-- Pick the highest resolution Clock for Clock_Realtime
-- ??? This code currently doesn't work (see c94007[ab] for example)
-- if syssgi (SGI_CYCLECNTR_SIZE) = 64 then
-- Real_Time_Clock_Id := CLOCK_SGI_CYCLE;
-- else
-- Real_Time_Clock_Id := CLOCK_REALTIME;
-- end if;
end;
end System.Task_Primitives.Operations;

165
gcc/ada/s-taprop-linux.adb
View File

@ -40,44 +40,32 @@ pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during
-- tasking operations. It causes infinite loops and other problems.
with System.Tasking.Debug;
-- used for Known_Tasks
with Interfaces.C;
-- used for int
-- size_t
with System.Parameters;
-- used for Size_Type
with System.Tasking.Debug;
-- used for Known_Tasks
with System.Interrupt_Management;
-- used for Keep_Unmasked
-- Abort_Task_Interrupt
-- Interrupt_ID
with System.Parameters;
-- used for Size_Type
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_Id
with Ada.Exceptions;
-- used for Raise_Exception
-- Raise_From_Signal_Handler
-- Exception_Id
with System.Soft_Links;
-- used for Defer/Undefer_Abort
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes
with System.Soft_Links;
-- used for Abort_Defer/Undefer
with Ada.Exceptions;
-- used for Raise_Exception
-- Raise_From_Signal_Handler
-- Exception_Id
with Unchecked_Conversion;
with Unchecked_Deallocation;
@ -90,8 +78,6 @@ package body System.Task_Primitives.Operations is
use System.Parameters;
use System.OS_Primitives;
package SSL renames System.Soft_Links;
----------------
-- Local Data --
----------------
@ -111,12 +97,10 @@ package body System.Task_Primitives.Operations is
-- 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 set of signals that should be unblocked in all tasks
-- The followings are internal configuration constants needed
Priority_Ceiling_Emulation : constant Boolean := True;
Next_Serial_Number : Task_Serial_Number := 100;
-- We start at 100, to reserve some special values for
-- using in error checking.
@ -127,9 +111,6 @@ package body System.Task_Primitives.Operations is
Dispatching_Policy : Character;
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
-- Indicates whether FIFO_Within_Priorities is set
-- The following are effectively constants, but they need to
-- be initialized by calling a pthread_ function.
@ -280,14 +261,11 @@ package body System.Task_Primitives.Operations is
(Prio : System.Any_Priority;
L : access Lock)
is
pragma Unreferenced (Prio);
Result : Interfaces.C.int;
begin
if Priority_Ceiling_Emulation then
L.Ceiling := Prio;
end if;
Result := pthread_mutex_init (L.L'Access, Mutex_Attr'Access);
Result := pthread_mutex_init (L, Mutex_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
@ -319,7 +297,7 @@ package body System.Task_Primitives.Operations is
procedure Finalize_Lock (L : access Lock) is
Result : Interfaces.C.int;
begin
Result := pthread_mutex_destroy (L.L'Access);
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
end Finalize_Lock;
@ -336,37 +314,13 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
Result : Interfaces.C.int;
begin
if Priority_Ceiling_Emulation then
declare
Self_ID : constant Task_Id := Self;
Result := pthread_mutex_lock (L);
Ceiling_Violation := Result = EINVAL;
begin
if Self_ID.Common.LL.Active_Priority > L.Ceiling then
Ceiling_Violation := True;
return;
end if;
-- Assume the cause of EINVAL is a priority ceiling violation
L.Saved_Priority := Self_ID.Common.LL.Active_Priority;
if Self_ID.Common.LL.Active_Priority < L.Ceiling then
Self_ID.Common.LL.Active_Priority := L.Ceiling;
end if;
Result := pthread_mutex_lock (L.L'Access);
pragma Assert (Result = 0);
Ceiling_Violation := False;
end;
else
Result := pthread_mutex_lock (L.L'Access);
Ceiling_Violation := Result = EINVAL;
-- Assume the cause of EINVAL is a priority ceiling violation
pragma Assert (Result = 0 or else Result = EINVAL);
end if;
pragma Assert (Result = 0 or else Result = EINVAL);
end Write_Lock;
procedure Write_Lock
@ -405,25 +359,9 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access Lock) is
Result : Interfaces.C.int;
begin
if Priority_Ceiling_Emulation then
declare
Self_ID : constant Task_Id := Self;
begin
Result := pthread_mutex_unlock (L.L'Access);
pragma Assert (Result = 0);
if Self_ID.Common.LL.Active_Priority > L.Saved_Priority then
Self_ID.Common.LL.Active_Priority := L.Saved_Priority;
end if;
end;
else
Result := pthread_mutex_unlock (L.L'Access);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_unlock (L);
pragma Assert (Result = 0);
end Unlock;
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
@ -553,14 +491,8 @@ package body System.Task_Primitives.Operations is
Abs_Time : Duration;
Request : aliased timespec;
Result : Interfaces.C.int;
begin
-- Only the little window between deferring abort and
-- locking Self_ID is the reason we need to
-- check for pending abort and priority change below! :(
SSL.Abort_Defer.all;
if Single_Lock then
Lock_RTS;
end if;
@ -611,7 +543,6 @@ package body System.Task_Primitives.Operations is
end if;
Result := sched_yield;
SSL.Abort_Undefer.all;
end Timed_Delay;
---------------------
@ -678,12 +609,6 @@ package body System.Task_Primitives.Operations is
begin
T.Common.Current_Priority := Prio;
if Priority_Ceiling_Emulation then
if T.Common.LL.Active_Priority < Prio then
T.Common.LL.Active_Priority := Prio;
end if;
end if;
-- Priorities are in range 1 .. 99 on GNU/Linux, so we map
-- map 0 .. 31 to 1 .. 32
@ -693,7 +618,7 @@ package body System.Task_Primitives.Operations is
Result := pthread_setschedparam
(T.Common.LL.Thread, SCHED_RR, Param'Access);
elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
Result := pthread_setschedparam
(T.Common.LL.Thread, SCHED_FIFO, Param'Access);
@ -1167,6 +1092,26 @@ package body System.Task_Primitives.Operations is
begin
Environment_Task_Id := Environment_Task;
Interrupt_Management.Initialize;
-- Prepare the set of signals that should be unblocked in all tasks
Result := sigemptyset (Unblocked_Signal_Mask'Access);
pragma Assert (Result = 0);
for J in Interrupt_Management.Interrupt_ID loop
if System.Interrupt_Management.Keep_Unmasked (J) then
Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
pragma Assert (Result = 0);
end if;
end loop;
Result := pthread_mutexattr_init (Mutex_Attr'Access);
pragma Assert (Result = 0);
Result := pthread_condattr_init (Cond_Attr'Access);
pragma Assert (Result = 0);
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-- Initialize the global RTS lock
@ -1196,26 +1141,4 @@ package body System.Task_Primitives.Operations is
end if;
end Initialize;
begin
declare
Result : Interfaces.C.int;
begin
-- Prepare the set of signals that should unblocked in all tasks
Result := sigemptyset (Unblocked_Signal_Mask'Access);
pragma Assert (Result = 0);
for J in Interrupt_Management.Interrupt_ID loop
if System.Interrupt_Management.Keep_Unmasked (J) then
Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
pragma Assert (Result = 0);
end if;
end loop;
Result := pthread_mutexattr_init (Mutex_Attr'Access);
pragma Assert (Result = 0);
Result := pthread_condattr_init (Cond_Attr'Access);
pragma Assert (Result = 0);
end;
end System.Task_Primitives.Operations;

72
gcc/ada/s-taprop-lynxos.adb
View File

@ -44,6 +44,14 @@ pragma Polling (Off);
with System.Tasking.Debug;
-- used for Known_Tasks
with System.Interrupt_Management;
-- used for Keep_Unmasked
-- Abort_Task_Interrupt
-- Interrupt_ID
with System.OS_Primitives;
-- used for Delay_Modes
with System.Task_Info;
-- used for Task_Info_Type
@ -51,29 +59,9 @@ with Interfaces.C;
-- used for int
-- size_t
with System.Interrupt_Management;
-- used for Keep_Unmasked
-- Abort_Task_Interrupt
-- Interrupt_ID
with System.Parameters;
-- used for Size_Type
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_Id
with System.Soft_Links;
-- used for Defer/Undefer_Abort
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes
with Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
@ -85,8 +73,6 @@ package body System.Task_Primitives.Operations is
use System.Parameters;
use System.OS_Primitives;
package SSL renames System.Soft_Links;
----------------
-- Local Data --
----------------
@ -127,9 +113,6 @@ package body System.Task_Primitives.Operations is
Dispatching_Policy : Character;
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
-- Indicates whether FIFO_Within_Priorities is set
Foreign_Task_Elaborated : aliased Boolean := True;
-- Used to identified fake tasks (i.e., non-Ada Threads)
@ -560,12 +543,6 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int;
begin
-- Only the little window between deferring abort and
-- locking Self_ID is the reason we need to
-- check for pending abort and priority change below!
SSL.Abort_Defer.all;
if Single_Lock then
Lock_RTS;
end if;
@ -632,7 +609,6 @@ package body System.Task_Primitives.Operations is
end if;
Result := sched_yield;
SSL.Abort_Undefer.all;
end Timed_Delay;
---------------------
@ -703,7 +679,7 @@ package body System.Task_Primitives.Operations is
Result := pthread_setschedparam
(T.Common.LL.Thread, SCHED_RR, Param'Access);
elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
Result := pthread_setschedparam
(T.Common.LL.Thread, SCHED_FIFO, Param'Access);
@ -1302,6 +1278,20 @@ package body System.Task_Primitives.Operations is
begin
Environment_Task_Id := Environment_Task;
Interrupt_Management.Initialize;
-- Prepare the set of signals that should unblocked in all tasks
Result := sigemptyset (Unblocked_Signal_Mask'Access);
pragma Assert (Result = 0);
for J in Interrupt_Management.Interrupt_ID loop
if System.Interrupt_Management.Keep_Unmasked (J) then
Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
pragma Assert (Result = 0);
end if;
end loop;
-- Initialize the lock used to synchronize chain of all ATCBs
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
@ -1332,20 +1322,4 @@ package body System.Task_Primitives.Operations is
end if;
end Initialize;
begin
declare
Result : Interfaces.C.int;
begin
-- Prepare the set of signals that should unblocked in all tasks
Result := sigemptyset (Unblocked_Signal_Mask'Access);
pragma Assert (Result = 0);
for J in Interrupt_Management.Interrupt_ID loop
if System.Interrupt_Management.Keep_Unmasked (J) then
Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
pragma Assert (Result = 0);
end if;
end loop;
end;
end System.Task_Primitives.Operations;

40
gcc/ada/s-taprop-mingw.adb
View File

@ -43,6 +43,9 @@ pragma Polling (Off);
with System.Tasking.Debug;
-- used for Known_Tasks
with System.OS_Primitives;
-- used for Delay_Modes
with Interfaces.C;
-- used for int
-- size_t
@ -56,22 +59,6 @@ with System.OS_Interface;
with System.Parameters;
-- used for Size_Type
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_Id
with System.Soft_Links;
-- used for Defer/Undefer_Abort
-- to initialize TSD for a C thread, in function Self
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes
with System.Task_Info;
-- used for Unspecified_Task_Info
@ -92,8 +79,6 @@ package body System.Task_Primitives.Operations is
-- permit to have more than 30 tasks running at the same time. Note that
-- we set the stack size for non tasking programs on System unit.
package SSL renames System.Soft_Links;
----------------
-- Local Data --
----------------
@ -112,9 +97,6 @@ package body System.Task_Primitives.Operations is
Dispatching_Policy : Character;
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
-- Indicates whether FIFO_Within_Priorities is set
Foreign_Task_Elaborated : aliased Boolean := True;
-- Used to identified fake tasks (i.e., non-Ada Threads)
@ -595,12 +577,6 @@ package body System.Task_Primitives.Operations is
Timedout : Boolean;
begin
-- Only the little window between deferring abort and
-- locking Self_ID is the reason we need to
-- check for pending abort and priority change below!
SSL.Abort_Defer.all;
if Single_Lock then
Lock_RTS;
end if;
@ -651,7 +627,6 @@ package body System.Task_Primitives.Operations is
end if;
Yield;
SSL.Abort_Undefer.all;
end Timed_Delay;
------------
@ -702,7 +677,7 @@ package body System.Task_Primitives.Operations is
(T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio)));
pragma Assert (Res = True);
if FIFO_Within_Priorities then
if Dispatching_Policy = 'F' then
-- Annex D requirement [RM D.2.2 par. 9]:
-- If the task drops its priority due to the loss of inherited
@ -883,7 +858,7 @@ package body System.Task_Primitives.Operations is
Set_Priority (T, Priority);
if Time_Slice_Val = 0 or else FIFO_Within_Priorities then
if Time_Slice_Val = 0 or else Dispatching_Policy = 'F' then
-- Here we need Annex E semantics so we disable the NT priority
-- boost. A priority boost is temporarily given by the system to a
-- thread when it is taken out of a wait state.
@ -997,10 +972,11 @@ package body System.Task_Primitives.Operations is
begin
Environment_Task_Id := Environment_Task;
OS_Primitives.Initialize;
if Time_Slice_Val = 0 or else FIFO_Within_Priorities then
if Time_Slice_Val = 0 or else Dispatching_Policy = 'F' then
-- Here we need Annex E semantics, switch the current process to the
-- Here we need Annex D semantics, switch the current process to the
-- High_Priority_Class.
Discard :=

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

@ -43,37 +43,23 @@ pragma Polling (Off);
with System.Tasking.Debug;
-- used for Known_Tasks
with System.OS_Primitives;
-- used for Delay_Modes
-- Clock
with Interfaces.OS2Lib.Errors;
with Interfaces.OS2Lib.Threads;
with Interfaces.OS2Lib.Synchronization;
with Interfaces.C;
-- used for size_t
with Interfaces.C.Strings;
-- used for Null_Ptr
with Interfaces.OS2Lib.Errors;
with Interfaces.OS2Lib.Threads;
with Interfaces.OS2Lib.Synchronization;
with System.Parameters;
-- used for Size_Type
with System.Tasking;
-- used for Task_Id
with System.Parameters;
-- used for Size_Type
with System.Soft_Links;
-- used for Defer/Undefer_Abort
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes
-- Clock
with Unchecked_Conversion;
with Unchecked_Deallocation;
@ -82,7 +68,6 @@ package body System.Task_Primitives.Operations is
package IC renames Interfaces.C;
package ICS renames Interfaces.C.Strings;
package OSP renames System.OS_Primitives;
package SSL renames System.Soft_Links;
use Interfaces.OS2Lib;
use Interfaces.OS2Lib.Errors;
@ -599,12 +584,6 @@ package body System.Task_Primitives.Operations is
Count : aliased ULONG; -- Used to store dummy result
begin
-- Only the little window between deferring abort and
-- locking Self_ID is the reason we need to
-- check for pending abort and priority change below! :(
SSL.Abort_Defer.all;
if Single_Lock then
Lock_RTS;
else
@ -672,7 +651,6 @@ package body System.Task_Primitives.Operations is
end if;
System.OS_Interface.Yield;
SSL.Abort_Undefer.all;
end Timed_Delay;
------------
@ -1244,6 +1222,20 @@ package body System.Task_Primitives.Operations is
begin
Environment_Task_Id := Environment_Task;
OS_Primitives.Initialize;
-- Initialize pointer to task local data.
-- This is done once, for all tasks.
Must_Not_Fail (DosAllocThreadLocalMemory
((Thread_Local_Data'Size + 31) / 32, -- nr of 32-bit words
To_PPVOID (Thread_Local_Data_Ptr'Access)));
-- Initialize thread local data for main thread
Thread_Local_Data_Ptr.Self_ID := null;
Thread_Local_Data_Ptr.Lock_Prio_Level := 0;
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-- Initialize the lock used to synchronize chain of all ATCBs
@ -1279,16 +1271,4 @@ package body System.Task_Primitives.Operations is
-- initialization needed for the environment task.
end Initialize;
begin
-- Initialize pointer to task local data.
-- This is done once, for all tasks.
Must_Not_Fail (DosAllocThreadLocalMemory
((Thread_Local_Data'Size + 31) / 32, -- nr of 32-bit words
To_PPVOID (Thread_Local_Data_Ptr'Access)));
-- Initialize thread local data for main thread
Thread_Local_Data_Ptr.Self_ID := null;
Thread_Local_Data_Ptr.Lock_Prio_Level := 0;
end System.Task_Primitives.Operations;

74
gcc/ada/s-taprop-posix.adb
View File

@ -49,6 +49,14 @@ pragma Polling (Off);
with System.Tasking.Debug;
-- used for Known_Tasks
with System.Interrupt_Management;
-- used for Keep_Unmasked
-- Abort_Task_Interrupt
-- Interrupt_ID
with System.OS_Primitives;
-- used for Delay_Modes
with System.Task_Info;
-- used for Task_Info_Type
@ -56,29 +64,9 @@ with Interfaces.C;
-- used for int
-- size_t
with System.Interrupt_Management;
-- used for Keep_Unmasked
-- Abort_Task_Interrupt
-- Interrupt_ID
with System.Parameters;
-- used for Size_Type
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_Id
with System.Soft_Links;
-- used for Defer/Undefer_Abort
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes
with Unchecked_Conversion;
with Unchecked_Deallocation;
@ -91,8 +79,6 @@ package body System.Task_Primitives.Operations is
use System.Parameters;
use System.OS_Primitives;
package SSL renames System.Soft_Links;
----------------
-- Local Data --
----------------
@ -133,9 +119,6 @@ package body System.Task_Primitives.Operations is
Dispatching_Policy : Character;
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
-- Indicates whether FIFO_Within_Priorities is set.
Foreign_Task_Elaborated : aliased Boolean := True;
-- Used to identified fake tasks (i.e., non-Ada Threads).
@ -603,12 +586,6 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int;
begin
-- Only the little window between deferring abort and
-- locking Self_ID is the reason we need to
-- check for pending abort and priority change below! :(
SSL.Abort_Defer.all;
if Single_Lock then
Lock_RTS;
end if;
@ -673,7 +650,6 @@ package body System.Task_Primitives.Operations is
end if;
Result := sched_yield;
SSL.Abort_Undefer.all;
end Timed_Delay;
---------------------
@ -746,7 +722,7 @@ package body System.Task_Primitives.Operations is
Result := pthread_setschedparam
(T.Common.LL.Thread, SCHED_RR, Param'Access);
elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
Result := pthread_setschedparam
(T.Common.LL.Thread, SCHED_FIFO, Param'Access);
@ -1038,7 +1014,7 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
end Abort_Task;
----------------
----------------
-- Initialize --
----------------
@ -1323,6 +1299,20 @@ package body System.Task_Primitives.Operations is
begin
Environment_Task_Id := Environment_Task;
Interrupt_Management.Initialize;
-- Prepare the set of signals that should unblocked in all tasks
Result := sigemptyset (Unblocked_Signal_Mask'Access);
pragma Assert (Result = 0);
for J in Interrupt_Management.Interrupt_ID loop
if System.Interrupt_Management.Keep_Unmasked (J) then
Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
pragma Assert (Result = 0);
end if;
end loop;
-- Initialize the lock used to synchronize chain of all ATCBs.
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
@ -1352,20 +1342,4 @@ package body System.Task_Primitives.Operations is
end if;
end Initialize;
begin
declare
Result : Interfaces.C.int;
begin
-- Prepare the set of signals that should unblocked in all tasks
Result := sigemptyset (Unblocked_Signal_Mask'Access);
pragma Assert (Result = 0);
for J in Interrupt_Management.Interrupt_ID loop
if System.Interrupt_Management.Keep_Unmasked (J) then
Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
pragma Assert (Result = 0);
end if;
end loop;
end;
end System.Task_Primitives.Operations;

195
gcc/ada/s-taprop-solaris.adb
View File

@ -43,44 +43,30 @@ pragma Polling (Off);
with System.Tasking.Debug;
-- used for Known_Tasks
with Ada.Exceptions;
-- used for Raise_Exception
with GNAT.OS_Lib;
-- used for String_Access, Getenv
with Interfaces.C;
-- used for int
-- size_t
with System.Interrupt_Management;
-- used for Keep_Unmasked
-- Abort_Task_Interrupt
-- Interrupt_ID
with System.OS_Primitives;
-- used for Delay_Modes
pragma Warnings (Off);
with GNAT.OS_Lib;
-- used for String_Access, Getenv
pragma Warnings (On);
with Interfaces.C;
-- used for int
-- size_t
with System.Parameters;
-- used for Size_Type
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_Id
-- ATCB components and types
with System.Task_Info;
-- to initialize Task_Info for a C thread, in function Self
with System.Soft_Links;
-- used for Defer/Undefer_Abort
-- to initialize TSD for a C thread, in function Self
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes
with Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
@ -90,11 +76,8 @@ package body System.Task_Primitives.Operations is
use Interfaces.C;
use System.OS_Interface;
use System.Parameters;
use Ada.Exceptions;
use System.OS_Primitives;
package SSL renames System.Soft_Links;
----------------
-- Local Data --
----------------
@ -280,7 +263,6 @@ package body System.Task_Primitives.Operations is
Old_Set : aliased sigset_t;
Result : Interfaces.C.int;
pragma Unreferenced (Result);
begin
-- It is not safe to raise an exception when using ZCX and the GCC
@ -425,11 +407,73 @@ package body System.Task_Primitives.Operations is
begin
Environment_Task_Id := Environment_Task;
-- This is done in Enter_Task, but this is too late for the
Interrupt_Management.Initialize;
-- Prepare the set of signals that should unblocked in all tasks
Result := sigemptyset (Unblocked_Signal_Mask'Access);
pragma Assert (Result = 0);
for J in Interrupt_Management.Interrupt_ID loop
if System.Interrupt_Management.Keep_Unmasked (J) then
Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
pragma Assert (Result = 0);
end if;
end loop;
if Dispatching_Policy = 'F' then
declare
Result : Interfaces.C.long;
Class_Info : aliased struct_pcinfo;
Secs, Nsecs : Interfaces.C.long;
begin
-- If a pragma Time_Slice is specified, takes the value in account
if Time_Slice_Val > 0 then
-- Convert Time_Slice_Val (microseconds) into seconds and
-- nanoseconds
Secs := Time_Slice_Val / 1_000_000;
Nsecs := (Time_Slice_Val rem 1_000_000) * 1_000;
-- Otherwise, default to no time slicing (i.e run until blocked)
else
Secs := RT_TQINF;
Nsecs := RT_TQINF;
end if;
-- Get the real time class id.
Class_Info.pc_clname (1) := 'R';
Class_Info.pc_clname (2) := 'T';
Class_Info.pc_clname (3) := ASCII.NUL;
Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_GETCID,
Class_Info'Address);
-- Request the real time class
Prio_Param.pc_cid := Class_Info.pc_cid;
Prio_Param.rt_pri := pri_t (Class_Info.rt_maxpri);
Prio_Param.rt_tqsecs := Secs;
Prio_Param.rt_tqnsecs := Nsecs;
Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_SETPARMS,
Prio_Param'Address);
Using_Real_Time_Class := Result /= -1;
end;
end if;
Specific.Initialize (Environment_Task);
-- The following is done in Enter_Task, but this is too late for the
-- Environment Task, since we need to call Self in Check_Locks when
-- the run time is compiled with assertions on.
Specific.Initialize (Environment_Task);
Specific.Set (Environment_Task);
-- Initialize the lock used to synchronize chain of all ATCBs.
@ -496,7 +540,7 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = ENOMEM then
Raise_Exception (Storage_Error'Identity, "Failed to allocate a lock");
raise Storage_Error with "Failed to allocate a lock";
end if;
end Initialize_Lock;
@ -513,7 +557,7 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = ENOMEM then
Raise_Exception (Storage_Error'Identity, "Failed to allocate a lock");
raise Storage_Error with "Failed to allocate a lock";
end if;
end Initialize_Lock;
@ -1244,12 +1288,6 @@ package body System.Task_Primitives.Operations is
Yielded : Boolean := False;
begin
-- Only the little window between deferring abort and
-- locking Self_ID is the reason we need to
-- check for pending abort and priority change below!
SSL.Abort_Defer.all;
if Single_Lock then
Lock_RTS;
end if;
@ -1310,8 +1348,6 @@ package body System.Task_Primitives.Operations is
if not Yielded then
thr_yield;
end if;
SSL.Abort_Undefer.all;
end Timed_Delay;
------------
@ -1643,7 +1679,7 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = ENOMEM then
Raise_Exception (Storage_Error'Identity, "Failed to allocate a lock");
raise Storage_Error with "Failed to allocate a lock";
end if;
-- Initialize internal condition variable
@ -1872,75 +1908,4 @@ package body System.Task_Primitives.Operations is
end if;
end Resume_Task;
-- Package elaboration
begin
declare
Result : Interfaces.C.int;
begin
-- Prepare the set of signals that should unblocked in all tasks
Result := sigemptyset (Unblocked_Signal_Mask'Access);
pragma Assert (Result = 0);
for J in Interrupt_Management.Interrupt_ID loop
if System.Interrupt_Management.Keep_Unmasked (J) then
Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
pragma Assert (Result = 0);
end if;
end loop;
-- We need the following code to support automatic creation of fake
-- ATCB's for C threads that call the Ada run-time system, even if
-- we use a faster way of getting Self for real Ada tasks.
Result := thr_keycreate (ATCB_Key'Access, System.Null_Address);
pragma Assert (Result = 0);
end;
if Dispatching_Policy = 'F' then
declare
Result : Interfaces.C.long;
Class_Info : aliased struct_pcinfo;
Secs, Nsecs : Interfaces.C.long;
begin
-- If a pragma Time_Slice is specified, takes the value in account.
if Time_Slice_Val > 0 then
-- Convert Time_Slice_Val (microseconds) into seconds and
-- nanoseconds
Secs := Time_Slice_Val / 1_000_000;
Nsecs := (Time_Slice_Val rem 1_000_000) * 1_000;
-- Otherwise, default to no time slicing (i.e run until blocked)
else
Secs := RT_TQINF;
Nsecs := RT_TQINF;
end if;
-- Get the real time class id.
Class_Info.pc_clname (1) := 'R';
Class_Info.pc_clname (2) := 'T';
Class_Info.pc_clname (3) := ASCII.NUL;
Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_GETCID,
Class_Info'Address);
-- Request the real time class
Prio_Param.pc_cid := Class_Info.pc_cid;
Prio_Param.rt_pri := pri_t (Class_Info.rt_maxpri);
Prio_Param.rt_tqsecs := Secs;
Prio_Param.rt_tqnsecs := Nsecs;
Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_SETPARMS,
Prio_Param'Address);
Using_Real_Time_Class := Result /= -1;
end;
end if;
end System.Task_Primitives.Operations;

79
gcc/ada/s-taprop-tru64.adb
View File

@ -43,6 +43,14 @@ pragma Polling (Off);
with System.Tasking.Debug;
-- used for Known_Tasks
with System.Interrupt_Management;
-- used for Keep_Unmasked
-- Abort_Task_Interrupt
-- Interrupt_ID
with System.OS_Primitives;
-- used for Delay_Modes
with System.Task_Info;
-- used for Task_Info_Type
@ -53,30 +61,9 @@ with Interfaces.C;
-- used for int
-- size_t
with System.Interrupt_Management;
-- used for Keep_Unmasked
-- Abort_Task_Interrupt
-- Interrupt_ID
with System.Parameters;
-- used for Size_Type
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_Id
-- ATCB components and types
with System.Soft_Links;
-- used for Defer/Undefer_Abort
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes
with Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
@ -88,8 +75,6 @@ package body System.Task_Primitives.Operations is
use System.Parameters;
use System.OS_Primitives;
package SSL renames System.Soft_Links;
----------------
-- Local Data --
----------------
@ -120,9 +105,6 @@ package body System.Task_Primitives.Operations is
Dispatching_Policy : Character;
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
-- Indicates whether FIFO_Within_Priorities is set
Curpid : pid_t;
Foreign_Task_Elaborated : aliased Boolean := True;
@ -527,12 +509,6 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int;
begin
-- Only the little window between deferring abort and
-- locking Self_ID is the reason we need to
-- check for pending abort and priority change below! :(
SSL.Abort_Defer.all;
if Single_Lock then
Lock_RTS;
end if;
@ -585,7 +561,6 @@ package body System.Task_Primitives.Operations is
end if;
Yield;
SSL.Abort_Undefer.all;
end Timed_Delay;
---------------------
@ -661,7 +636,7 @@ package body System.Task_Primitives.Operations is
Result := pthread_setschedparam
(T.Common.LL.Thread, SCHED_RR, Param'Access);
elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
Result := pthread_setschedparam
(T.Common.LL.Thread, SCHED_FIFO, Param'Access);
@ -846,7 +821,7 @@ package body System.Task_Primitives.Operations is
Result := pthread_attr_setschedpolicy
(Attributes'Access, System.OS_Interface.SCHED_RR);
elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
Result := pthread_attr_setschedpolicy
(Attributes'Access, System.OS_Interface.SCHED_FIFO);
@ -1240,6 +1215,22 @@ package body System.Task_Primitives.Operations is
begin
Environment_Task_Id := Environment_Task;
Interrupt_Management.Initialize;
-- Prepare the set of signals that should unblocked in all tasks
Result := sigemptyset (Unblocked_Signal_Mask'Access);
pragma Assert (Result = 0);
for J in Interrupt_Management.Interrupt_ID loop
if System.Interrupt_Management.Keep_Unmasked (J) then
Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
pragma Assert (Result = 0);
end if;
end loop;
Curpid := getpid;
-- Initialize the lock used to synchronize chain of all ATCBs
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
@ -1269,22 +1260,4 @@ package body System.Task_Primitives.Operations is
end if;
end Initialize;
begin
declare
Result : Interfaces.C.int;
begin
-- Prepare the set of signals that should unblocked in all tasks
Result := sigemptyset (Unblocked_Signal_Mask'Access);
pragma Assert (Result = 0);
for J in Interrupt_Management.Interrupt_ID loop
if System.Interrupt_Management.Keep_Unmasked (J) then
Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
pragma Assert (Result = 0);
end if;
end loop;
end;
Curpid := getpid;
end System.Task_Primitives.Operations;

47
gcc/ada/s-taprop-vms.adb
View File

@ -43,6 +43,9 @@ pragma Polling (Off);
with System.Tasking.Debug;
-- used for Known_Tasks
with System.OS_Primitives;
-- used for Delay_Modes
with Interfaces.C;
-- used for int
-- size_t
@ -50,21 +53,8 @@ with Interfaces.C;
with System.Parameters;
-- used for Size_Type
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_Id
with System.Soft_Links;
-- used for Defer/Undefer_Abort
-- Set_Exc_Stack_Addr
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes
-- used for Get_Exc_Stack_Addr
with Unchecked_Conversion;
with Unchecked_Deallocation;
@ -105,9 +95,6 @@ package body System.Task_Primitives.Operations is
Dispatching_Policy : Character;
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
-- Indicates whether FIFO_Within_Priorities is set.
Foreign_Task_Elaborated : aliased Boolean := True;
-- Used to identified fake tasks (i.e., non-Ada Threads).
@ -156,6 +143,9 @@ package body System.Task_Primitives.Operations is
function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
function Get_Exc_Stack_Addr return Address;
-- Replace System.Soft_Links.Get_Exc_Stack_Addr_NT
procedure Timer_Sleep_AST (ID : Address);
-- Signal the condition variable when AST fires.
@ -492,17 +482,12 @@ package body System.Task_Primitives.Operations is
Yielded : Boolean := False;
begin
-- Only the little window between deferring abort and
-- locking Self_ID is the reason we need to
-- check for pending abort and priority change below!
if Single_Lock then
Lock_RTS;
end if;
-- More comments required in body below ???
SSL.Abort_Defer.all;
Write_Lock (Self_ID);
if Time /= 0.0 or else Mode /= Relative then
@ -562,8 +547,6 @@ package body System.Task_Primitives.Operations is
Result := sched_yield;
pragma Assert (Result = 0);
end if;
SSL.Abort_Undefer.all;
end Timed_Delay;
---------------------
@ -629,7 +612,7 @@ package body System.Task_Primitives.Operations is
Result := pthread_setschedparam
(T.Common.LL.Thread, SCHED_RR, Param'Access);
elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
Result := pthread_setschedparam
(T.Common.LL.Thread, SCHED_FIFO, Param'Access);
@ -749,9 +732,6 @@ package body System.Task_Primitives.Operations is
if Result = 0 then
Succeeded := True;
Self_ID.Common.LL.Exc_Stack_Ptr := new Exc_Stack_T;
SSL.Set_Exc_Stack_Addr
(To_Address (Self_ID),
Self_ID.Common.LL.Exc_Stack_Ptr (Exc_Stack_T'Last)'Address);
else
if not Single_Lock then
@ -766,6 +746,15 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
end Initialize_TCB;
------------------------
-- Get_Exc_Stack_Addr --
------------------------
function Get_Exc_Stack_Addr return Address is
begin
return Self.Common.LL.Exc_Stack_Ptr (Exc_Stack_T'Last)'Address;
end Get_Exc_Stack_Addr;
-----------------
-- Create_Task --
-----------------
@ -1169,6 +1158,8 @@ package body System.Task_Primitives.Operations is
begin
Environment_Task_Id := Environment_Task;
SSL.Get_Exc_Stack_Addr := Get_Exc_Stack_Addr'Access;
-- Initialize the lock used to synchronize chain of all ATCBs
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);

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

@ -44,8 +44,8 @@ with System.OS_Interface;
-- used for Thread_Id
package System.Task_Primitives.Operations is
pragma Preelaborate;
pragma Elaborate_Body;
package ST renames System.Tasking;
package OSI renames System.OS_Interface;
@ -356,8 +356,8 @@ package System.Task_Primitives.Operations is
(Self_ID : ST.Task_Id;
Time : Duration;
Mode : ST.Delay_Modes);
-- Implement the semantics of the delay statement. It is assumed that
-- the caller is not abort-deferred and does not hold any locks.
-- Implement the semantics of the delay statement.
-- The caller should be abort-deferred and should not hold any locks.
procedure Wakeup
(T : ST.Task_Id;

2
gcc/ada/s-tarest.adb
View File

@ -505,6 +505,8 @@ package body System.Tasking.Restricted.Stages is
procedure Init_RTS is
begin
Tasking.Initialize;
-- Initialize lock used to implement mutual exclusion between all tasks
STPO.Initialize_Lock (Global_Task_Lock'Access, STPO.Global_Task_Level);

3
gcc/ada/s-tasdeb.ads
View File

@ -38,6 +38,7 @@ with System.Tasking;
with System.OS_Interface;
package System.Tasking.Debug is
pragma Preelaborate;
------------------------------------------
-- Application-level debugging routines --
@ -66,7 +67,7 @@ package System.Tasking.Debug is
-- General GDB support --
-------------------------
Known_Tasks : array (0 .. 999) of Task_Id;
Known_Tasks : array (0 .. 999) of Task_Id := (others => null);
-- Global array of tasks read by gdb, and updated by
-- Create_Task and Finalize_TCB

10
gcc/ada/s-tasinf-irix-athread.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- --
@ -41,11 +41,12 @@
-- This unit may be used directly from an application program by providing
-- an appropriate WITH, and the interface can be expected to remain stable.
-- This is the SGI (libathread) specific version of this module.
-- This is the SGI (libathread) specific version of this module
with System.OS_Interface;
package System.Task_Info is
pragma Preelaborate;
pragma Elaborate_Body;
-- To ensure that a body is allowed
@ -147,7 +148,7 @@ package System.Task_Info is
ANY_CPU : constant CPU_Number := CPU_Number'First;
type Non_Degrading_Priority is range 0 .. 255;
-- Specification of IRIX Non Degrading Priorities.
-- Specification of IRIX Non Degrading Priorities
--
-- WARNING: IRIX priorities have the reverse meaning of Ada priorities.
-- The lower the priority value, the greater the greater the
@ -203,8 +204,7 @@ package System.Task_Info is
CPU : CPU_Number := ANY_CPU;
Resident : Page_Locking := NOLOCK;
NDPRI : Non_Degrading_Priority := NDP_NONE) return sproc_t;
-- Allocates a sproc_t control structure and creates the
-- corresponding sproc.
-- Allocates a sproc_t control structure and creates corresponding sproc
Invalid_CPU_Number : exception;
Permission_Error : exception;

28
gcc/ada/s-tasinf-irix.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. --
-- --
-- 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- --
@ -44,14 +44,12 @@
-- This is the IRIX (kernel threads) version of this package
with Interfaces.C;
with System.OS_Interface;
package System.Task_Info is
pragma Preelaborate;
pragma Elaborate_Body;
-- To ensure that a body is allowed
package OSI renames System.OS_Interface;
-----------------------------------------
-- Implementation of Task_Info Feature --
-----------------------------------------
@ -91,27 +89,13 @@ package System.Task_Info is
subtype Thread_Scheduling_Priority is Integer range
No_Specified_Priority .. 255;
function Min (Policy : Interfaces.C.int) return Interfaces.C.int
renames OSI.sched_get_priority_min;
subtype FIFO_Priority is Thread_Scheduling_Priority range 0 .. 255;
function Max (Policy : Interfaces.C.int) return Interfaces.C.int
renames OSI.sched_get_priority_max;
subtype RR_Priority is Thread_Scheduling_Priority range 0 .. 255;
subtype FIFO_Priority is Thread_Scheduling_Priority range
Thread_Scheduling_Priority (Min (OSI.SCHED_FIFO)) ..
Thread_Scheduling_Priority (Max (OSI.SCHED_FIFO));
subtype TS_Priority is Thread_Scheduling_Priority range 1 .. 40;
subtype RR_Priority is Thread_Scheduling_Priority range
Thread_Scheduling_Priority (Min (OSI.SCHED_RR)) ..
Thread_Scheduling_Priority (Max (OSI.SCHED_RR));
subtype TS_Priority is Thread_Scheduling_Priority range
Thread_Scheduling_Priority (Min (OSI.SCHED_TS)) ..
Thread_Scheduling_Priority (Max (OSI.SCHED_TS));
subtype OTHER_Priority is Thread_Scheduling_Priority range
Thread_Scheduling_Priority (Min (OSI.SCHED_OTHER)) ..
Thread_Scheduling_Priority (Max (OSI.SCHED_OTHER));
subtype OTHER_Priority is Thread_Scheduling_Priority range 1 .. 40;
subtype CPU_Number is Integer range -1 .. Integer'Last;
ANY_CPU : constant CPU_Number := CPU_Number'First;

3
gcc/ada/s-tasinf-solaris.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. --
-- --
-- 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- --
@ -46,6 +46,7 @@
with System.OS_Interface;
package System.Task_Info is
pragma Preelaborate;
pragma Elaborate_Body;
-- To ensure that a body is allowed

3
gcc/ada/s-tasinf-tru64.ads
View File

@ -7,7 +7,7 @@
-- S p e c --
-- (Compiler Interface) --
-- --
-- Copyright (C) 1998-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1998-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- --
@ -45,6 +45,7 @@
-- This is a DEC Unix 4.0d version of this package.
package System.Task_Info is
pragma Preelaborate;
pragma Elaborate_Body;
-- To ensure that a body is allowed

3
gcc/ada/s-tasinf.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. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -42,6 +42,7 @@
-- an appropriate WITH, and the interface can be expected to remain stable.
package System.Task_Info is
pragma Preelaborate;
pragma Elaborate_Body;
-- To ensure that a body is allowed

47
gcc/ada/s-taskin.adb
View File

@ -48,6 +48,21 @@ package body System.Tasking is
package STPO renames System.Task_Primitives.Operations;
---------------------
-- Detect_Blocking --
---------------------
function Detect_Blocking return Boolean is
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.
begin
return GL_Detect_Blocking = 1;
end Detect_Blocking;
----------
-- Self --
----------
@ -116,8 +131,12 @@ package body System.Tasking is
All_Tasks_List := T;
end Initialize_ATCB;
----------------
-- Initialize --
----------------
Main_Task_Image : constant String := "main_task";
-- Image of environment task.
-- Image of environment task
Main_Priority : Integer;
pragma Import (C, Main_Priority, "__gl_main_priority");
@ -125,26 +144,21 @@ package body System.Tasking is
-- Priority, because we use the value -1 to indicate the default
-- main priority, and that is of course not in Priority'range.
----------------------------
-- Tasking Initialization --
----------------------------
Initialized : Boolean := False;
-- Used to prevent multiple calls to Initialize
-- This block constitutes the first part of the initialization of the
-- GNARL. This includes creating data structures to make the initial thread
-- into the environment task. The last part of the initialization is done
-- in System.Tasking.Initialization or System.Tasking.Restricted.Stages.
-- All the initializations used to be in Tasking.Initialization, but this
-- is no longer possible with the run time simplification (including
-- optimized PO and the restricted run time) since one cannot rely on
-- System.Tasking.Initialization being present, as was done before.
begin
declare
procedure Initialize is
T : Task_Id;
Success : Boolean;
Base_Priority : Any_Priority;
begin
if Initialized then
return;
end if;
Initialized := True;
-- Initialize Environment Task
if Main_Priority = Unspecified_Priority then
@ -170,5 +184,6 @@ begin
-- in ravenscar mode. Rest of the initialization is done in Init_RTS.
T.Entry_Calls (1).Self := T;
end;
end Initialize;
end System.Tasking;

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

@ -54,6 +54,7 @@ with System.Task_Primitives;
with Unchecked_Conversion;
package System.Tasking is
pragma Preelaborate;
-------------------
-- Locking Rules --
@ -342,8 +343,9 @@ package System.Tasking is
type Access_Boolean is access all Boolean;
Detect_Blocking : constant Boolean;
-- Boolean constant set True iff Detect_Blocking is active
function Detect_Blocking return Boolean;
pragma Inline (Detect_Blocking);
-- Return whether the Detect_Blocking pragma is enabled.
----------------------------------------------
-- Ada_Task_Control_Block (ATCB) definition --
@ -977,9 +979,19 @@ package System.Tasking is
-- has exclusive access to this field.
end record;
---------------------
-- Initialize_ATCB --
---------------------
--------------------
-- Initialization --
--------------------
procedure Initialize;
-- This procedure constitutes the first part of the initialization of the
-- GNARL. This includes creating data structures to make the initial thread
-- into the environment task. The last part of the initialization is done
-- in System.Tasking.Initialization or System.Tasking.Restricted.Stages.
-- All the initializations used to be in Tasking.Initialization, but this
-- is no longer possible with the run time simplification (including
-- optimized PO and the restricted run time) since one cannot rely on
-- System.Tasking.Initialization being present, as was done before.
procedure Initialize_ATCB
(Self_ID : Task_Id;
@ -999,14 +1011,6 @@ package System.Tasking is
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.
Detect_Blocking : constant Boolean := GL_Detect_Blocking = 1;
type Activation_Chain is record
T_ID : Task_Id;
end record;

1
gcc/ada/s-taspri-hpux-dce.ads
View File

@ -45,6 +45,7 @@ with System.OS_Interface;
-- pthread_t
package System.Task_Primitives is
pragma Preelaborate;
type Lock is limited private;
-- Should be used for implementation of protected objects

118
gcc/ada/s-taspri-linux.ads
View File

@ -1,118 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T A S K _ P R I M I T I V E S --
-- --
-- S p e c --
-- --
-- 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNARL; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is the GNU/Linux (GNU/LinuxThreads) version of this package
-- This package provides low-level support for most tasking features
pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during
-- tasking operations. It causes infinite loops and other problems.
with System.OS_Interface;
-- used for pthread_mutex_t
-- pthread_cond_t
-- pthread_t
package System.Task_Primitives is
type Lock is limited private;
-- Should be used for implementation of protected objects
type RTS_Lock is limited private;
-- Should be used inside the runtime system. The difference between Lock
-- and the RTS_Lock is that the later one serves only as a semaphore so
-- that do not check for ceiling violations.
type Suspension_Object is limited private;
-- Should be used for the implementation of Ada.Synchronous_Task_Control
type Task_Body_Access is access procedure;
-- Pointer to the task body's entry point (or possibly a wrapper
-- declared local to the GNARL).
type Private_Data is limited private;
-- Any information that the GNULLI needs maintained on a per-task basis.
-- A component of this type is guaranteed to be included in the
-- Ada_Task_Control_Block.
private
type Prio_Array_Type is array (System.Any_Priority) of Integer;
type Lock is record
L : aliased System.OS_Interface.pthread_mutex_t;
Ceiling : System.Any_Priority := System.Any_Priority'First;
Saved_Priority : System.Any_Priority := System.Any_Priority'First;
end record;
type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
type Suspension_Object is record
State : Boolean;
pragma Atomic (State);
-- Boolean that indicates whether the object is open. This field is
-- marked Atomic to ensure that we can read its value without locking
-- the access to the Suspension_Object.
Waiting : Boolean;
-- Flag showing if there is a task already suspended on this object
L : aliased System.OS_Interface.pthread_mutex_t;
-- Protection for ensuring mutual exclusion on the Suspension_Object
CV : aliased System.OS_Interface.pthread_cond_t;
-- Condition variable used to queue threads until the condition is
-- signaled.
end record;
type Private_Data is record
Thread : aliased System.OS_Interface.pthread_t;
pragma Atomic (Thread);
-- Thread field may be updated by two different threads of control.
-- (See, Enter_Task and Create_Task in s-taprop.adb).
-- They put the same value (thr_self value). We do not want to
-- use lock on those operations and the only thing we have to
-- make sure is that they are updated in atomic fashion.
CV : aliased System.OS_Interface.pthread_cond_t;
L : aliased RTS_Lock;
-- Protection for all components is lock L
Active_Priority : System.Any_Priority := System.Any_Priority'First;
-- Simulated active priority, used only if Priority_Ceiling_Support
-- is True.
end record;
end System.Task_Primitives;

3
gcc/ada/s-taspri-lynxos.ads
View File

@ -32,7 +32,7 @@
-- --
------------------------------------------------------------------------------
-- This is a LynxOS version of this package, derived from 7staspri.ads
-- This is a LynxOS version of this package, derived from s-taspri-posix.ads
pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during
@ -44,6 +44,7 @@ with System.OS_Interface;
-- pthread_t
package System.Task_Primitives is
pragma Preelaborate;
type Lock is limited private;
-- Should be used for implementation of protected objects

1
gcc/ada/s-taspri-mingw.ads
View File

@ -43,6 +43,7 @@ with System.OS_Interface;
-- pthread_t
package System.Task_Primitives is
pragma Preelaborate;
type Lock is limited private;
-- Should be used for implementation of protected objects

11
gcc/ada/s-taspri-os2.ads
View File

@ -44,15 +44,12 @@ with Interfaces.OS2Lib.Threads;
with Interfaces.OS2Lib.Synchronization;
package System.Task_Primitives is
pragma Preelaborate;
-- Why are these commented out ???
-- type Lock is limited private;
type Lock is limited private;
-- Should be used for implementation of protected objects.
-- type RTS_Lock is limited private;
type RTS_Lock is limited private;
-- Should be used inside the runtime system.
-- The difference between Lock and the RTS_Lock is that the later
-- one serves only as a semaphore so that do not check for
@ -62,12 +59,12 @@ package System.Task_Primitives is
-- Pointer to the task body's entry point (or possibly a wrapper
-- declared local to the GNARL).
-- type Private_Data is limited private;
type Private_Data is limited private;
-- Any information that the GNULLI needs maintained on a per-task
-- basis. A component of this type is guaranteed to be included
-- in the Ada_Task_Control_Block.
-- private (why commented out???)
private
type Lock is record
Mutex : aliased Interfaces.OS2Lib.Synchronization.HMTX;

1
gcc/ada/s-taspri-posix.ads
View File

@ -46,6 +46,7 @@ with System.OS_Interface;
-- pthread_t
package System.Task_Primitives is
pragma Preelaborate;
type Lock is limited private;
-- Should be used for implementation of protected objects

1
gcc/ada/s-taspri-tru64.ads
View File

@ -49,6 +49,7 @@ with System.OS_Interface;
-- pthread_t
package System.Task_Primitives is
pragma Preelaborate;
type Lock is limited private;
-- Should be used for implementation of protected objects

1
gcc/ada/s-taspri-vms.ads
View File

@ -49,6 +49,7 @@ with System.OS_Interface;
-- pthread_t
package System.Task_Primitives is
pragma Preelaborate;
type Lock is limited private;
-- Should be used for implementation of protected objects

1
gcc/ada/s-taspri-vxworks.ads
View File

@ -40,6 +40,7 @@ pragma Polling (Off);
with System.OS_Interface;
package System.Task_Primitives is
pragma Preelaborate;
type Lock is limited private;
-- Should be used for implementation of protected objects

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

@ -846,8 +846,6 @@ package body System.Tasking.Stages is
SSL.Set_Jmpbuf_Address := SSL.Set_Jmpbuf_Address_NT'Access;
SSL.Get_Sec_Stack_Addr := SSL.Get_Sec_Stack_Addr_NT'Access;
SSL.Set_Sec_Stack_Addr := SSL.Set_Sec_Stack_Addr_NT'Access;
SSL.Get_Exc_Stack_Addr := SSL.Get_Exc_Stack_Addr_NT'Access;
SSL.Set_Exc_Stack_Addr := SSL.Set_Exc_Stack_Addr_NT'Access;
SSL.Check_Abort_Status := SSL.Check_Abort_Status_NT'Access;
SSL.Get_Stack_Info := SSL.Get_Stack_Info_NT'Access;
@ -1135,7 +1133,6 @@ package body System.Tasking.Stages is
procedure To_Stderr (S : String);
pragma Import (Ada, To_Stderr, "__gnat_to_stderr");
use System.Task_Info;
use System.Soft_Links;
use System.Standard_Library;

3
gcc/ada/s-tpopsp-solaris.adb
View File

@ -42,9 +42,10 @@ package body Specific is
----------------
procedure Initialize (Environment_Task : Task_Id) is
pragma Unreferenced (Environment_Task);
Result : Interfaces.C.int;
begin
Result := thr_setspecific (ATCB_Key, To_Address (Environment_Task));
Result := thr_keycreate (ATCB_Key'Access, System.Null_Address);
pragma Assert (Result = 0);
end Initialize;

1
gcc/ada/s-traces.ads
View File

@ -55,6 +55,7 @@
-- To add a new target, just adapt System.Traces.Send to your own purpose.
package System.Traces is
pragma Preelaborate;
type Trace_T is
(

1
gcc/ada/s-traent-vms.ads
View File

@ -38,6 +38,7 @@
-- This is the Alpha/OpenVMS version of this package
package System.Traceback_Entries is
pragma Preelaborate;
type Traceback_Entry is record
PC : System.Address;

7
gcc/ada/s-traent.ads
View File

@ -41,12 +41,13 @@
-- address of a call instruction part of the call-chain.
package System.Traceback_Entries is
pragma Preelaborate;
subtype Traceback_Entry is System.Address;
-- This subtype defines what each traceback array entry contains.
-- This subtype defines what each traceback array entry contains
Null_TB_Entry : constant Traceback_Entry := System.Null_Address;
-- This is the value to be used when initializing an entry.
-- This is the value to be used when initializing an entry
function PC_For (TB_Entry : Traceback_Entry) return System.Address;
pragma Inline (PC_For);
@ -55,6 +56,6 @@ package System.Traceback_Entries is
function TB_Entry_For (PC : System.Address) return Traceback_Entry;
pragma Inline (TB_Entry_For);
-- Returns an entry representing a frame for a call instruction at PC.
-- Returns an entry representing a frame for a call instruction at PC
end System.Traceback_Entries;

1
gcc/ada/s-tratas.ads
View File

@ -41,6 +41,7 @@
with System.Tasking;
package System.Traces.Tasking is
pragma Preelaborate;
package ST renames System.Tasking;