-- --
-- 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- --
-- --
------------------------------------------------------------------------------
--- This is the Windows NT/95 version.
+-- This is the Windows NT/95 version
with System.OS_Primitives;
-- used for Clock
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;
return DY;
end Year;
+begin
+ System.OS_Primitives.Initialize;
end Ada.Calendar;
return DY;
end Year;
+begin
+ System.OS_Primitives.Initialize;
end Ada.Calendar;
-- --
------------------------------------------------------------------------------
-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
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
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;
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;
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.
end if;
end if;
- Initialization.Undefer_Abort (Self_ID);
+ SSL.Abort_Undefer.all;
end Set_Priority;
end Ada.Dynamic_Priorities;
-- --
-- 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 --
-- Default version for most targets
+with System.Standard_Library; use System.Standard_Library;
+
procedure Ada.Exceptions.Last_Chance_Handler
(Except : Exception_Occurrence)
is
-- 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);
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 (" : ");
-- --
------------------------------------------------------------------------------
-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
-- Set_True
-- Suspend_Until_True
-pragma Warnings (On);
-
package body Ada.Synchronous_Task_Control is
----------------
-- --
------------------------------------------------------------------------------
-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;
-- 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);
-- --
------------------------------------------------------------------------------
+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 --
-- "=" --
---------
- 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 "=";
-----------------
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;
-------------------
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;
-- --
------------------------------------------------------------------------------
-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;
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);
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;
-- 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;
-- --
-- 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- --
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
-- --
-- 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- --
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;
-- --
-- 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- --
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
-- --
-- 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- --
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,
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);
-- 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
-- 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;
-- 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;
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;
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
(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);
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);
end Setup_Interrupt_Mask;
begin
+ Interrupt_Management.Initialize;
Environment_Mask := (others => False);
All_Tasks_Mask := (others => True);
package body System.Interrupt_Management is
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ null;
+ end Initialize;
+
end System.Interrupt_Management;
-- 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.
with Interfaces.C;
-- used for "int"
+
package body System.Interrupt_Management is
use System.OS_Interface;
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;
-- mark it as reserved.
Reserve (0) := True;
- end;
+ end Initialize;
+
end System.Interrupt_Management;
-- 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.
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.
-- mark it as reserved.
Reserve (0) := True;
- end;
+ end Initialize;
+
end System.Interrupt_Management;
-- 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;
-- 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.
-- 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;
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.
-- mark it as reserved.
Reserve (0) := True;
- end;
+ end Initialize;
+
end System.Interrupt_Management;
-- 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.
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 --
----------------------
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
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.
-- mark it as reserved.
Reserve (0) := True;
- end;
+ end Initialize;
+
end System.Interrupt_Management;
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,
Bufquo => Interrupt_Bufquo,
Lognam => "GNAT_Interrupt_Mailbox",
Flags => CMB_M_READONLY);
-
pragma Assert ((Status and 1) = 1);
Sys_Assign
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;
-- 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.
-- sigset_t
package System.Interrupt_Management is
-
- pragma Elaborate_Body;
+ pragma Preelaborate;
type Interrupt_Mask is limited private;
-- 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;
-- 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.
-- 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.
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.
-- The abort signal must also be unmasked
Keep_Unmasked (Abort_Task_Signal) := True;
- end;
+ end Initialize;
+
end System.Interrupt_Management;
-- 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
-- used for int
package System.Interrupt_Management is
-
- pragma Elaborate_Body;
+ pragma Preelaborate;
type Interrupt_Mask is limited private;
-- 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
-- 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
-- used for int
package System.Interrupt_Management is
-
- pragma Elaborate_Body;
+ pragma Preelaborate;
type Interrupt_Mask is limited private;
-- 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
-- This is the NT version of this package
-with Ada.Exceptions;
with Interfaces.C;
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;
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;
end if;
end Timed_Delay;
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ null;
+ end Initialize;
+
end System.OS_Primitives;
end if;
end Timed_Delay;
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ null;
+ end Initialize;
+
end System.OS_Primitives;
end if;
end Timed_Delay;
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ null;
+ end Initialize;
+
end System.OS_Primitives;
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 --
----------------
-- 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.
end if;
end Timed_Delay;
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ null;
+ end Initialize;
+
end System.OS_Primitives;
-- 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,
-- 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
-- --
-- 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- --
-- then relink your application as usual.
--
+pragma Warnings (Off);
with GNAT.OS_Lib;
+pragma Warnings (On);
package body System.Program_Info is
-- --
-- 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- --
-- 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;
-- --
-- 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- --
-- 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
-- --
-- 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- --
-- 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 --
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;
-----------------------
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;
---------------------
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;
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 --
---------------------------
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 --
---------------------------
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 --
---------------------------
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;
------------------------------------------------------------------------------
-- 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
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;
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;
-- 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
--
-- 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);
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;
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;
-- --
-- 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- --
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;
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
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;
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;
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;
-----------------------------
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;
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;
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
-- --
-- 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- --
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
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
-- 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,
(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);
(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);
(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);
(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);
(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);
(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);
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;
-- 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
pragma Warnings (Off);
-- Turn off warnings since so many unreferenced parameters
- No_Tasking : Boolean;
- -- Comment required here ???
-
----------------
-- Abort_Task --
----------------
----------------
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
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;
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;
use System.OS_Primitives;
package PIO renames System.Task_Primitives.Interrupt_Operations;
- package SSL renames System.Soft_Links;
----------------
-- Local Data --
-- 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)
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;
end if;
Result := sched_yield;
- SSL.Abort_Undefer.all;
end Timed_Delay;
---------------------
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);
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
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);
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
-- 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
use System.Parameters;
use System.OS_Primitives;
- package SSL renames System.Soft_Links;
-
-----------------
-- Local Data --
-----------------
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;
end if;
pthread_yield;
- SSL.Abort_Undefer.all;
end Timed_Delay;
---------------------
pragma Assert (Result = 0);
end Abort_Task;
- ----------------
+ ----------------
-- Initialize --
----------------
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.
end if;
end Initialize_Athread_Library;
--- Package initialization
-
-begin
- Initialize_Athread_Library;
end System.Task_Primitives.Operations;
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
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;
use System.OS_Primitives;
use System.Parameters;
- package SSL renames System.Soft_Links;
-
----------------
-- Local Data --
----------------
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;
end if;
Yield;
- SSL.Abort_Undefer.all;
end Timed_Delay;
---------------------
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);
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)
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;
-- 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;
use System.Parameters;
use System.OS_Primitives;
- package SSL renames System.Soft_Links;
-
----------------
-- Local Data --
----------------
-- 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.
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.
(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);
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;
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
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
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;
end if;
Result := sched_yield;
- SSL.Abort_Undefer.all;
end Timed_Delay;
---------------------
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
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);
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
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;
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
-- 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
use System.Parameters;
use System.OS_Primitives;
- package SSL renames System.Soft_Links;
-
----------------
-- Local Data --
----------------
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)
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;
end if;
Result := sched_yield;
- SSL.Abort_Undefer.all;
end Timed_Delay;
---------------------
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);
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);
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;
with System.Tasking.Debug;
-- used for Known_Tasks
+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.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
-- 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 --
----------------
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)
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;
end if;
Yield;
- SSL.Abort_Undefer.all;
end Timed_Delay;
------------
(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
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.
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 :=
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;
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;
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
end if;
System.OS_Interface.Yield;
- SSL.Abort_Undefer.all;
end Timed_Delay;
------------
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
-- 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;
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
-- 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;
use System.Parameters;
use System.OS_Primitives;
- package SSL renames System.Soft_Links;
-
----------------
-- Local Data --
----------------
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).
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;
end if;
Result := sched_yield;
- SSL.Abort_Undefer.all;
end Timed_Delay;
---------------------
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);
pragma Assert (Result = 0);
end Abort_Task;
- ----------------
+ ----------------
-- Initialize --
----------------
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);
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;
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
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 --
----------------
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
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.
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;
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;
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;
if not Yielded then
thr_yield;
end if;
-
- SSL.Abort_Undefer.all;
end Timed_Delay;
------------
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
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;
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
-- 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
use System.Parameters;
use System.OS_Primitives;
- package SSL renames System.Soft_Links;
-
----------------
-- Local Data --
----------------
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;
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;
end if;
Yield;
- SSL.Abort_Undefer.all;
end Timed_Delay;
---------------------
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);
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);
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);
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;
with System.Tasking.Debug;
-- used for Known_Tasks
+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.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;
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).
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.
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
Result := sched_yield;
pragma Assert (Result = 0);
end if;
-
- SSL.Abort_Undefer.all;
end Timed_Delay;
---------------------
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);
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
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 --
-----------------
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);
-- 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;
(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;
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);
with System.OS_Interface;
package System.Tasking.Debug is
+ pragma Preelaborate;
------------------------------------------
-- Application-level debugging routines --
-- 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
-- --
-- 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- --
-- 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
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
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;
-- --
-- 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- --
-- 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 --
-----------------------------------------
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;
-- --
-- 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- --
with System.OS_Interface;
package System.Task_Info is
+ pragma Preelaborate;
pragma Elaborate_Body;
-- To ensure that a body is allowed
-- 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- --
-- 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
-- --
-- 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- --
-- 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
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 --
----------
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");
-- 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
-- in ravenscar mode. Rest of the initialization is done in Init_RTS.
T.Entry_Calls (1).Self := T;
- end;
+ end Initialize;
+
end System.Tasking;
with Unchecked_Conversion;
package System.Tasking is
+ pragma Preelaborate;
-------------------
-- Locking Rules --
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 --
-- 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;
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;
-- pthread_t
package System.Task_Primitives is
+ pragma Preelaborate;
type Lock is limited private;
-- Should be used for implementation of protected objects
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
-- --
------------------------------------------------------------------------------
--- 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
-- pthread_t
package System.Task_Primitives is
+ pragma Preelaborate;
type Lock is limited private;
-- Should be used for implementation of protected objects
-- pthread_t
package System.Task_Primitives is
+ pragma Preelaborate;
type Lock is limited private;
-- Should be used for implementation of protected objects
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
-- 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;
-- pthread_t
package System.Task_Primitives is
+ pragma Preelaborate;
type Lock is limited private;
-- Should be used for implementation of protected objects
-- pthread_t
package System.Task_Primitives is
+ pragma Preelaborate;
type Lock is limited private;
-- Should be used for implementation of protected objects
-- pthread_t
package System.Task_Primitives is
+ pragma Preelaborate;
type Lock is limited private;
-- Should be used for implementation of protected objects
with System.OS_Interface;
package System.Task_Primitives is
+ pragma Preelaborate;
type Lock is limited private;
-- Should be used for implementation of protected objects
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;
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;
----------------
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;
-- To add a new target, just adapt System.Traces.Send to your own purpose.
package System.Traces is
+ pragma Preelaborate;
type Trace_T is
(
-- This is the Alpha/OpenVMS version of this package
package System.Traceback_Entries is
+ pragma Preelaborate;
type Traceback_Entry is record
PC : System.Address;
-- 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);
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;
with System.Tasking;
package System.Traces.Tasking is
+ pragma Preelaborate;
package ST renames System.Tasking;
projects / platform / upstream / linaro-gcc.git / commitdiff