diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2005-09-05 07:46:06 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2005-09-05 07:46:06 +0000 |
| commit | 51e69f04c0161130375d97979e76cbfd0bd2d45e (patch) | |
| tree | a6cb1c584d1988e1b5e855ab100aea15d2e374d2 | |
| parent | 69e0f3d4a84e6e6226f05799ea4789427e996d42 (diff) | |
| download | gcc-51e69f04c0161130375d97979e76cbfd0bd2d45e.tar.gz | |
* 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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@103847 138bc75d-0d04-0410-961f-82ee72b054a4
81 files changed, 854 insertions, 1318 deletions
diff --git a/gcc/ada/a-calend-mingw.adb b/gcc/ada/a-calend-mingw.adb index 8dcc303261f..71599bd419c 100644 --- a/gcc/ada/a-calend-mingw.adb +++ b/gcc/ada/a-calend-mingw.adb @@ -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; diff --git a/gcc/ada/a-calend.adb b/gcc/ada/a-calend.adb index 0ed5455f5b9..c0180e4e995 100644 --- a/gcc/ada/a-calend.adb +++ b/gcc/ada/a-calend.adb @@ -476,4 +476,6 @@ package body Ada.Calendar is return DY; end Year; +begin + System.OS_Primitives.Initialize; end Ada.Calendar; diff --git a/gcc/ada/a-dynpri.adb b/gcc/ada/a-dynpri.adb index 46a16a5df4c..a8acb2342b4 100644 --- a/gcc/ada/a-dynpri.adb +++ b/gcc/ada/a-dynpri.adb @@ -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; diff --git a/gcc/ada/a-elchha.adb b/gcc/ada/a-elchha.adb index 6323db4bad5..34530edea41 100644 --- a/gcc/ada/a-elchha.adb +++ b/gcc/ada/a-elchha.adb @@ -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 (" : "); diff --git a/gcc/ada/a-sytaco.adb b/gcc/ada/a-sytaco.adb index 739bc4d2f67..98fcfaa5f98 100644 --- a/gcc/ada/a-sytaco.adb +++ b/gcc/ada/a-sytaco.adb @@ -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 ---------------- diff --git a/gcc/ada/a-sytaco.ads b/gcc/ada/a-sytaco.ads index 798ce33584d..5e6315cdba5 100644 --- a/gcc/ada/a-sytaco.ads +++ b/gcc/ada/a-sytaco.ads @@ -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); diff --git a/gcc/ada/a-taside.adb b/gcc/ada/a-taside.adb index b5d92b8cb59..a63719d5cbe 100644 --- a/gcc/ada/a-taside.adb +++ b/gcc/ada/a-taside.adb @@ -31,32 +31,28 @@ -- -- ------------------------------------------------------------------------------ +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 +pragma Warnings (On); -with System.Task_Primitives.Operations; --- used for Self - -with Unchecked_Conversion; +package body Ada.Task_Identification is -pragma Warnings (Off); + use System.Parameters; -package body Ada.Task_Identification is + 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; diff --git a/gcc/ada/a-taside.ads b/gcc/ada/a-taside.ads index 556aafd96f5..fcceff5de57 100644 --- a/gcc/ada/a-taside.ads +++ b/gcc/ada/a-taside.ads @@ -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; diff --git a/gcc/ada/g-os_lib.adb b/gcc/ada/g-os_lib.adb index 9e11735eff4..825c05c5786 100644 --- a/gcc/ada/g-os_lib.adb +++ b/gcc/ada/g-os_lib.adb @@ -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; diff --git a/gcc/ada/g-string.ads b/gcc/ada/g-string.ads index 6920f6b042d..f4f2e696da9 100644 --- a/gcc/ada/g-string.ads +++ b/gcc/ada/g-string.ads @@ -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 diff --git a/gcc/ada/s-auxdec-vms_64.ads b/gcc/ada/s-auxdec-vms_64.ads index 9899ccca902..3bf7a5b69b5 100644 --- a/gcc/ada/s-auxdec-vms_64.ads +++ b/gcc/ada/s-auxdec-vms_64.ads @@ -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; diff --git a/gcc/ada/s-auxdec.ads b/gcc/ada/s-auxdec.ads index 9353af4f384..0a0bd35fa47 100644 --- a/gcc/ada/s-auxdec.ads +++ b/gcc/ada/s-auxdec.ads @@ -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 diff --git a/gcc/ada/s-exctab.adb b/gcc/ada/s-exctab.adb index d549a8eee45..7b7cfc14c21 100644 --- a/gcc/ada/s-exctab.adb +++ b/gcc/ada/s-exctab.adb @@ -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); diff --git a/gcc/ada/s-inmaop-posix.adb b/gcc/ada/s-inmaop-posix.adb index ea613a67477..2dab2de08ab 100644 --- a/gcc/ada/s-inmaop-posix.adb +++ b/gcc/ada/s-inmaop-posix.adb @@ -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); diff --git a/gcc/ada/s-inmaop-vms.adb b/gcc/ada/s-inmaop-vms.adb index 851da216178..ba421ec6a0a 100644 --- a/gcc/ada/s-inmaop-vms.adb +++ b/gcc/ada/s-inmaop-vms.adb @@ -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); diff --git a/gcc/ada/s-intman-dummy.adb b/gcc/ada/s-intman-dummy.adb index ad890275e81..9a115106672 100644 --- a/gcc/ada/s-intman-dummy.adb +++ b/gcc/ada/s-intman-dummy.adb @@ -35,4 +35,13 @@ package body System.Interrupt_Management is + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + null; + end Initialize; + end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-irix-athread.adb b/gcc/ada/s-intman-irix-athread.adb index 71cc0cb7aa7..71b20fc6dbd 100644 --- a/gcc/ada/s-intman-irix-athread.adb +++ b/gcc/ada/s-intman-irix-athread.adb @@ -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: - - 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) - + 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) + + ---------------- + -- 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; diff --git a/gcc/ada/s-intman-irix.adb b/gcc/ada/s-intman-irix.adb index 51630a3a9b1..d47912d00b7 100644 --- a/gcc/ada/s-intman-irix.adb +++ b/gcc/ada/s-intman-irix.adb @@ -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"); + + -- Get interrupt state. Defined in a-init.c + -- The input argument is the interrupt number, + -- and the result is one of the following: -begin - declare - function State (Int : Interrupt_ID) return Character; - pragma Import (C, State, "__gnat_get_interrupt_state"); + 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) - -- Get interrupt state. Defined in a-init.c - -- The input argument is the interrupt number, - -- and the result is one of the following: + ---------------- + -- Initialize -- + ---------------- - 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) + 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; diff --git a/gcc/ada/s-intman-mingw.adb b/gcc/ada/s-intman-mingw.adb index 90823ae9df1..f531750ab5a 100644 --- a/gcc/ada/s-intman-mingw.adb +++ b/gcc/ada/s-intman-mingw.adb @@ -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. +with System.OS_Interface; use System.OS_Interface; --- PLEASE DO NOT add any dependences on other packages. --- This package is designed to work with or without tasking support. +package body System.Interrupt_Management is --- See the other warnings in the package specification before making any --- modifications to this file. + ---------------- + -- Initialize -- + ---------------- --- 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. + procedure Initialize is + begin + -- "Reserve" all the interrupts, except those that are explicitely + -- defined. -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; - 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; diff --git a/gcc/ada/s-intman-posix.adb b/gcc/ada/s-intman-posix.adb index d363300ad1e..26ddbe5f717 100644 --- a/gcc/ada/s-intman-posix.adb +++ b/gcc/ada/s-intman-posix.adb @@ -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; diff --git a/gcc/ada/s-intman-solaris.adb b/gcc/ada/s-intman-solaris.adb index 6c11e7e1f4d..05f1e042429 100644 --- a/gcc/ada/s-intman-solaris.adb +++ b/gcc/ada/s-intman-solaris.adb @@ -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; diff --git a/gcc/ada/s-intman-vms.adb b/gcc/ada/s-intman-vms.adb index 3889f526797..7ad7f278d9b 100644 --- a/gcc/ada/s-intman-vms.adb +++ b/gcc/ada/s-intman-vms.adb @@ -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; diff --git a/gcc/ada/s-intman-vms.ads b/gcc/ada/s-intman-vms.ads index f4bdd4bc8d1..028facc79fd 100644 --- a/gcc/ada/s-intman-vms.ads +++ b/gcc/ada/s-intman-vms.ads @@ -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; diff --git a/gcc/ada/s-intman-vxworks.adb b/gcc/ada/s-intman-vxworks.adb index 2dcaa06c77c..d31ad56d0ff 100644 --- a/gcc/ada/s-intman-vxworks.adb +++ b/gcc/ada/s-intman-vxworks.adb @@ -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 - 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: + ---------------- + -- Initialize -- + ---------------- - 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) + Initialized : Boolean := False; + procedure Initialize is + mask : aliased sigset_t; + Result : int; 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; diff --git a/gcc/ada/s-intman-vxworks.ads b/gcc/ada/s-intman-vxworks.ads index 6a9d5e5e22d..14ceb91a28e 100644 --- a/gcc/ada/s-intman-vxworks.ads +++ b/gcc/ada/s-intman-vxworks.ads @@ -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 diff --git a/gcc/ada/s-intman.ads b/gcc/ada/s-intman.ads index 9773a8ff7b0..a7909c91c49 100644 --- a/gcc/ada/s-intman.ads +++ b/gcc/ada/s-intman.ads @@ -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 diff --git a/gcc/ada/s-osprim-mingw.adb b/gcc/ada/s-osprim-mingw.adb index 65cc70a83b6..eb38ac8852f 100644 --- a/gcc/ada/s-osprim-mingw.adb +++ b/gcc/ada/s-osprim-mingw.adb @@ -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; + + 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. - -- 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; diff --git a/gcc/ada/s-osprim-os2.adb b/gcc/ada/s-osprim-os2.adb index b8c61a3a477..b8863f65dad 100644 --- a/gcc/ada/s-osprim-os2.adb +++ b/gcc/ada/s-osprim-os2.adb @@ -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; diff --git a/gcc/ada/s-osprim-posix.adb b/gcc/ada/s-osprim-posix.adb index d53ffc1d178..6d4431c6c8c 100644 --- a/gcc/ada/s-osprim-posix.adb +++ b/gcc/ada/s-osprim-posix.adb @@ -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; diff --git a/gcc/ada/s-osprim-solaris.adb b/gcc/ada/s-osprim-solaris.adb index bcda9fa5878..6e7436f7a01 100644 --- a/gcc/ada/s-osprim-solaris.adb +++ b/gcc/ada/s-osprim-solaris.adb @@ -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; diff --git a/gcc/ada/s-osprim-unix.adb b/gcc/ada/s-osprim-unix.adb index b058b5448e1..75110346914 100644 --- a/gcc/ada/s-osprim-unix.adb +++ b/gcc/ada/s-osprim-unix.adb @@ -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; diff --git a/gcc/ada/s-osprim-vms.adb b/gcc/ada/s-osprim-vms.adb index ae0647401d5..7d7a7dc510e 100644 --- a/gcc/ada/s-osprim-vms.adb +++ b/gcc/ada/s-osprim-vms.adb @@ -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 -- ---------------- diff --git a/gcc/ada/s-osprim-vms.ads b/gcc/ada/s-osprim-vms.ads index b4d6f2e86bc..91d545c4087 100644 --- a/gcc/ada/s-osprim-vms.ads +++ b/gcc/ada/s-osprim-vms.ads @@ -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. diff --git a/gcc/ada/s-osprim-vxworks.adb b/gcc/ada/s-osprim-vxworks.adb index afea1190258..85a7dce94ca 100644 --- a/gcc/ada/s-osprim-vxworks.adb +++ b/gcc/ada/s-osprim-vxworks.adb @@ -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; diff --git a/gcc/ada/s-osprim.ads b/gcc/ada/s-osprim.ads index 8f11c201483..8166bce5f6c 100644 --- a/gcc/ada/s-osprim.ads +++ b/gcc/ada/s-osprim.ads @@ -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 diff --git a/gcc/ada/s-proinf-irix-athread.adb b/gcc/ada/s-proinf-irix-athread.adb index 537538d2c99..1baf726e414 100644 --- a/gcc/ada/s-proinf-irix-athread.adb +++ b/gcc/ada/s-proinf-irix-athread.adb @@ -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 diff --git a/gcc/ada/s-proinf-irix-athread.ads b/gcc/ada/s-proinf-irix-athread.ads index 1a9ba65ff42..40b0cb6443b 100644 --- a/gcc/ada/s-proinf-irix-athread.ads +++ b/gcc/ada/s-proinf-irix-athread.ads @@ -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; diff --git a/gcc/ada/s-proinf.ads b/gcc/ada/s-proinf.ads index 1423dc61ee4..2a4e78e9766 100644 --- a/gcc/ada/s-proinf.ads +++ b/gcc/ada/s-proinf.ads @@ -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 diff --git a/gcc/ada/s-soflin.adb b/gcc/ada/s-soflin.adb index d18d020546c..02b57bfe364 100644 --- a/gcc/ada/s-soflin.adb +++ b/gcc/ada/s-soflin.adb @@ -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 -- --------------------------- @@ -260,26 +236,6 @@ package body System.Soft_Links is 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; diff --git a/gcc/ada/s-soflin.ads b/gcc/ada/s-soflin.ads index b813714515d..8f166e61263 100644 --- a/gcc/ada/s-soflin.ads +++ b/gcc/ada/s-soflin.ads @@ -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; diff --git a/gcc/ada/s-solita.adb b/gcc/ada/s-solita.adb index a072912ca65..920284764b4 100644 --- a/gcc/ada/s-solita.adb +++ b/gcc/ada/s-solita.adb @@ -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; diff --git a/gcc/ada/s-stache.ads b/gcc/ada/s-stache.ads index 6d855f2639a..7ccf95b57cd 100644 --- a/gcc/ada/s-stache.ads +++ b/gcc/ada/s-stache.ads @@ -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 diff --git a/gcc/ada/s-stalib.ads b/gcc/ada/s-stalib.ads index a3ccdcb75b8..8388e8d7ac2 100644 --- a/gcc/ada/s-stalib.ads +++ b/gcc/ada/s-stalib.ads @@ -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); diff --git a/gcc/ada/s-taprob.adb b/gcc/ada/s-taprob.adb index 14d1d7dc81e..cd762c7ec5b 100644 --- a/gcc/ada/s-taprob.adb +++ b/gcc/ada/s-taprob.adb @@ -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; diff --git a/gcc/ada/s-taprop-dummy.adb b/gcc/ada/s-taprop-dummy.adb index cd42f38361d..873b1fd78ae 100644 --- a/gcc/ada/s-taprop-dummy.adb +++ b/gcc/ada/s-taprop-dummy.adb @@ -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; diff --git a/gcc/ada/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb index 4efb4ec208a..5989c197a07 100644 --- a/gcc/ada/s-taprop-hpux-dce.adb +++ b/gcc/ada/s-taprop-hpux-dce.adb @@ -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); diff --git a/gcc/ada/s-taprop-irix-athread.adb b/gcc/ada/s-taprop-irix-athread.adb index 58de9f41852..43c0fa6380f 100644 --- a/gcc/ada/s-taprop-irix-athread.adb +++ b/gcc/ada/s-taprop-irix-athread.adb @@ -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; diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb index ac0b3b9f2bc..5c610b05854 100644 --- a/gcc/ada/s-taprop-irix.adb +++ b/gcc/ada/s-taprop-irix.adb @@ -49,28 +49,19 @@ 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.Parameters; --- used for Size_Type - -with System.Tasking; --- used for Ada_Task_Control_Block --- Task_Id +with System.OS_Primitives; +-- used for Delay_Modes -with System.Soft_Links; --- used for Defer/Undefer_Abort +with System.IO; +-- used for Put_Line --- 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.Parameters; +-- used for Size_Type with System.Program_Info; -- used for Default_Task_Stack @@ -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; diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index d255d7cebea..6cb7eb7e5cb 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -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.OS_Primitives; +-- used for Delay_Modes -with System.Tasking; --- used for Ada_Task_Control_Block --- Task_Id +with System.Soft_Links; +-- used for Abort_Defer/Undefer 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 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 - Result : Interfaces.C.int; + 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; - - begin - if Self_ID.Common.LL.Active_Priority > L.Ceiling then - Ceiling_Violation := True; - return; - end if; - - L.Saved_Priority := Self_ID.Common.LL.Active_Priority; + Result := pthread_mutex_lock (L); + Ceiling_Violation := Result = EINVAL; - 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 + -- 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; + begin 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; diff --git a/gcc/ada/s-taprop-lynxos.adb b/gcc/ada/s-taprop-lynxos.adb index d37c347e193..06313ed5fdf 100644 --- a/gcc/ada/s-taprop-lynxos.adb +++ b/gcc/ada/s-taprop-lynxos.adb @@ -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; diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index 925e93045e6..c18bdb3bfc9 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -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 := diff --git a/gcc/ada/s-taprop-os2.adb b/gcc/ada/s-taprop-os2.adb index 7ad80579b15..0455b404c86 100644 --- a/gcc/ada/s-taprop-os2.adb +++ b/gcc/ada/s-taprop-os2.adb @@ -43,37 +43,23 @@ pragma Polling (Off); with System.Tasking.Debug; -- used for Known_Tasks -with Interfaces.C; --- used for size_t - -with Interfaces.C.Strings; --- used for Null_Ptr +with System.OS_Primitives; +-- used for Delay_Modes +-- Clock with Interfaces.OS2Lib.Errors; with Interfaces.OS2Lib.Threads; with Interfaces.OS2Lib.Synchronization; -with System.Parameters; --- used for Size_Type +with Interfaces.C; +-- used for size_t -with System.Tasking; --- used for Task_Id +with Interfaces.C.Strings; +-- used for Null_Ptr 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; diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index a71c6dd79ec..3ad2659f7a7 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.adb @@ -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; diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb index c9f7aacd737..371f7411826 100644 --- a/gcc/ada/s-taprop-solaris.adb +++ b/gcc/ada/s-taprop-solaris.adb @@ -43,44 +43,30 @@ pragma Polling (Off); with System.Tasking.Debug; -- used for Known_Tasks -with Ada.Exceptions; --- used for Raise_Exception +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.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.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; diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb index 13178e575b7..d4846d545e3 100644 --- a/gcc/ada/s-taprop-tru64.adb +++ b/gcc/ada/s-taprop-tru64.adb @@ -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; diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb index a627d7c07ff..896dbe11c46 100644 --- a/gcc/ada/s-taprop-vms.adb +++ b/gcc/ada/s-taprop-vms.adb @@ -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); diff --git a/gcc/ada/s-taprop.ads b/gcc/ada/s-taprop.ads index 3b210441ca5..bf98c5cbba2 100644 --- a/gcc/ada/s-taprop.ads +++ b/gcc/ada/s-taprop.ads @@ -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; diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb index 4bf3965b613..f8d9a1fd096 100644 --- a/gcc/ada/s-tarest.adb +++ b/gcc/ada/s-tarest.adb @@ -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); diff --git a/gcc/ada/s-tasdeb.ads b/gcc/ada/s-tasdeb.ads index a94f8fc0b5b..d0c230d1f28 100644 --- a/gcc/ada/s-tasdeb.ads +++ b/gcc/ada/s-tasdeb.ads @@ -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 diff --git a/gcc/ada/s-tasinf-irix-athread.ads b/gcc/ada/s-tasinf-irix-athread.ads index 7bc21d38043..96a709d8190 100644 --- a/gcc/ada/s-tasinf-irix-athread.ads +++ b/gcc/ada/s-tasinf-irix-athread.ads @@ -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; diff --git a/gcc/ada/s-tasinf-irix.ads b/gcc/ada/s-tasinf-irix.ads index 9d71f62ebc8..eb8432d63b7 100644 --- a/gcc/ada/s-tasinf-irix.ads +++ b/gcc/ada/s-tasinf-irix.ads @@ -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; - - function Max (Policy : Interfaces.C.int) return Interfaces.C.int - renames OSI.sched_get_priority_max; - - subtype FIFO_Priority is Thread_Scheduling_Priority range - Thread_Scheduling_Priority (Min (OSI.SCHED_FIFO)) .. - Thread_Scheduling_Priority (Max (OSI.SCHED_FIFO)); + subtype FIFO_Priority is Thread_Scheduling_Priority range 0 .. 255; - subtype RR_Priority is Thread_Scheduling_Priority range - Thread_Scheduling_Priority (Min (OSI.SCHED_RR)) .. - Thread_Scheduling_Priority (Max (OSI.SCHED_RR)); + subtype RR_Priority is Thread_Scheduling_Priority range 0 .. 255; - subtype TS_Priority is Thread_Scheduling_Priority range - Thread_Scheduling_Priority (Min (OSI.SCHED_TS)) .. - Thread_Scheduling_Priority (Max (OSI.SCHED_TS)); + subtype TS_Priority is Thread_Scheduling_Priority range 1 .. 40; - 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; diff --git a/gcc/ada/s-tasinf-solaris.ads b/gcc/ada/s-tasinf-solaris.ads index 57eedcc7f9e..efa51b7e166 100644 --- a/gcc/ada/s-tasinf-solaris.ads +++ b/gcc/ada/s-tasinf-solaris.ads @@ -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 diff --git a/gcc/ada/s-tasinf-tru64.ads b/gcc/ada/s-tasinf-tru64.ads index f624fbc3359..895fde49a62 100644 --- a/gcc/ada/s-tasinf-tru64.ads +++ b/gcc/ada/s-tasinf-tru64.ads @@ -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 diff --git a/gcc/ada/s-tasinf.ads b/gcc/ada/s-tasinf.ads index 7e8ea58f8f0..8d8b2dd9da2 100644 --- a/gcc/ada/s-tasinf.ads +++ b/gcc/ada/s-tasinf.ads @@ -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 diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb index f38f952c8e1..fd76b575761 100644 --- a/gcc/ada/s-taskin.adb +++ b/gcc/ada/s-taskin.adb @@ -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 -- - ---------------------------- - - -- 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 + Initialized : Boolean := False; + -- Used to prevent multiple calls to Initialize + + 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; diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index f82cfc0ae26..e979b7ab13b 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -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; diff --git a/gcc/ada/s-taspri-hpux-dce.ads b/gcc/ada/s-taspri-hpux-dce.ads index 7f15a5dedbc..311df3fcae2 100644 --- a/gcc/ada/s-taspri-hpux-dce.ads +++ b/gcc/ada/s-taspri-hpux-dce.ads @@ -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 diff --git a/gcc/ada/s-taspri-linux.ads b/gcc/ada/s-taspri-linux.ads deleted file mode 100644 index cb426e15542..00000000000 --- a/gcc/ada/s-taspri-linux.ads +++ /dev/null @@ -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; diff --git a/gcc/ada/s-taspri-lynxos.ads b/gcc/ada/s-taspri-lynxos.ads index 53fa8b0280c..03eb447ac3f 100644 --- a/gcc/ada/s-taspri-lynxos.ads +++ b/gcc/ada/s-taspri-lynxos.ads @@ -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 diff --git a/gcc/ada/s-taspri-mingw.ads b/gcc/ada/s-taspri-mingw.ads index 874739f0990..8af68156a10 100644 --- a/gcc/ada/s-taspri-mingw.ads +++ b/gcc/ada/s-taspri-mingw.ads @@ -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 diff --git a/gcc/ada/s-taspri-os2.ads b/gcc/ada/s-taspri-os2.ads index d9a2cb4dd9b..502260e96d2 100644 --- a/gcc/ada/s-taspri-os2.ads +++ b/gcc/ada/s-taspri-os2.ads @@ -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; diff --git a/gcc/ada/s-taspri-posix.ads b/gcc/ada/s-taspri-posix.ads index fd328351f4c..22bad81b4e0 100644 --- a/gcc/ada/s-taspri-posix.ads +++ b/gcc/ada/s-taspri-posix.ads @@ -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 diff --git a/gcc/ada/s-taspri-tru64.ads b/gcc/ada/s-taspri-tru64.ads index 172f795536f..db281adc32e 100644 --- a/gcc/ada/s-taspri-tru64.ads +++ b/gcc/ada/s-taspri-tru64.ads @@ -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 diff --git a/gcc/ada/s-taspri-vms.ads b/gcc/ada/s-taspri-vms.ads index ebf88ce0ec8..7f3d8eae3e8 100644 --- a/gcc/ada/s-taspri-vms.ads +++ b/gcc/ada/s-taspri-vms.ads @@ -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 diff --git a/gcc/ada/s-taspri-vxworks.ads b/gcc/ada/s-taspri-vxworks.ads index 0198454ce25..dad195fe014 100644 --- a/gcc/ada/s-taspri-vxworks.ads +++ b/gcc/ada/s-taspri-vxworks.ads @@ -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 diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index a0b5f7ca25e..1ac7edb2dd0 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -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; diff --git a/gcc/ada/s-tpopsp-solaris.adb b/gcc/ada/s-tpopsp-solaris.adb index 15e3061bb29..176b186ae9c 100644 --- a/gcc/ada/s-tpopsp-solaris.adb +++ b/gcc/ada/s-tpopsp-solaris.adb @@ -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; diff --git a/gcc/ada/s-traces.ads b/gcc/ada/s-traces.ads index 928a3d81dec..2c6d00984b3 100644 --- a/gcc/ada/s-traces.ads +++ b/gcc/ada/s-traces.ads @@ -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 ( diff --git a/gcc/ada/s-traent-vms.ads b/gcc/ada/s-traent-vms.ads index b9f795dfa86..ab90478b0b4 100644 --- a/gcc/ada/s-traent-vms.ads +++ b/gcc/ada/s-traent-vms.ads @@ -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; diff --git a/gcc/ada/s-traent.ads b/gcc/ada/s-traent.ads index 1ba071f11f7..384c9a07041 100644 --- a/gcc/ada/s-traent.ads +++ b/gcc/ada/s-traent.ads @@ -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; diff --git a/gcc/ada/s-tratas.ads b/gcc/ada/s-tratas.ads index 31b85d6ad00..5a0b3348e8f 100644 --- a/gcc/ada/s-tratas.ads +++ b/gcc/ada/s-tratas.ads @@ -41,6 +41,7 @@ with System.Tasking; package System.Traces.Tasking is + pragma Preelaborate; package ST renames System.Tasking; |