Skip to content

R
riscv-gcc-1
Commit 90376fad by Arnaud Charlet Committed by Arnaud Charlet
Options

a-numaux-vms.ads, [...]: New files. 

2011-12-15  Arnaud Charlet  <charlet@adacore.com>

        * a-numaux-vms.ads, s-asthan-vms-ia64.adb, s-auxdec-vms-ia64.adb,       
        s-memory-vms_64.adb, s-memory-vms_64.ads, s-osinte-vms-ia64.adb,
        s-osinte-vms-ia64.ads, s-tasdeb-vms.adb: New files.

From-SVN: r182374
parent 0c5c7b00
Showing with 4521 additions and 0 deletions
gcc/ada/ChangeLog
2011-12-15 Arnaud Charlet <charlet@adacore.com>
* a-numaux-vms.ads, s-asthan-vms-ia64.adb, s-auxdec-vms-ia64.adb,
s-memory-vms_64.adb, s-memory-vms_64.ads, s-osinte-vms-ia64.adb,
s-osinte-vms-ia64.ads, s-tasdeb-vms.adb: New files.
2011-12-15 Vincent Pucci <pucci@adacore.com> 2011-12-15 Vincent Pucci <pucci@adacore.com>
* aspects.adb, aspects.ads Aspect_Dimension and * aspects.adb, aspects.ads Aspect_Dimension and
......
gcc/ada/a-numaux-vms.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . N U M E R I C S . A U X --
-- --
-- S p e c --
-- (VMS Version) --
-- --
-- Copyright (C) 2003-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides the basic computational interface for the generic
-- elementary functions. The C library version interfaces with the routines
-- in the C mathematical library, and is thus quite portable, although it may
-- not necessarily meet the requirements for accuracy in the numerics annex.
-- This is the VMS version
package Ada.Numerics.Aux is
pragma Pure;
type Double is digits 15;
pragma Float_Representation (IEEE_Float, Double);
-- Type Double is the type used to call the C routines. Note that this
-- is IEEE format even when running on VMS with VAX_Native representation
-- since we use the IEEE version of the C library with VMS.
-- We import these functions directly from C. Note that we label them
-- all as pure functions, because indeed all of them are in fact pure!
function Sin (X : Double) return Double;
pragma Import (C, Sin, "MATH$SIN_T");
pragma Pure_Function (Sin);
function Cos (X : Double) return Double;
pragma Import (C, Cos, "MATH$COS_T");
pragma Pure_Function (Cos);
function Tan (X : Double) return Double;
pragma Import (C, Tan, "MATH$TAN_T");
pragma Pure_Function (Tan);
function Exp (X : Double) return Double;
pragma Import (C, Exp, "MATH$EXP_T");
pragma Pure_Function (Exp);
function Sqrt (X : Double) return Double;
pragma Import (C, Sqrt, "MATH$SQRT_T");
pragma Pure_Function (Sqrt);
function Log (X : Double) return Double;
pragma Import (C, Log, "DECC$TLOG_2");
pragma Pure_Function (Log);
function Acos (X : Double) return Double;
pragma Import (C, Acos, "MATH$ACOS_T");
pragma Pure_Function (Acos);
function Asin (X : Double) return Double;
pragma Import (C, Asin, "MATH$ASIN_T");
pragma Pure_Function (Asin);
function Atan (X : Double) return Double;
pragma Import (C, Atan, "MATH$ATAN_T");
pragma Pure_Function (Atan);
function Sinh (X : Double) return Double;
pragma Import (C, Sinh, "MATH$SINH_T");
pragma Pure_Function (Sinh);
function Cosh (X : Double) return Double;
pragma Import (C, Cosh, "MATH$COSH_T");
pragma Pure_Function (Cosh);
function Tanh (X : Double) return Double;
pragma Import (C, Tanh, "MATH$TANH_T");
pragma Pure_Function (Tanh);
function Pow (X, Y : Double) return Double;
pragma Import (C, Pow, "DECC$TPOW_2");
pragma Pure_Function (Pow);
end Ada.Numerics.Aux;
gcc/ada/s-asthan-vms-ia64.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . A S T _ H A N D L I N G --
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the OpenVMS/IA64 version
with System; use System;
with System.IO;
with System.Machine_Code;
with System.Parameters;
with System.Tasking;
with System.Tasking.Rendezvous;
with System.Tasking.Initialization;
with System.Tasking.Utilities;
with System.Task_Primitives;
with System.Task_Primitives.Operations;
with System.Task_Primitives.Operations.DEC;
with Ada.Finalization;
with Ada.Task_Attributes;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
package body System.AST_Handling is
package ATID renames Ada.Task_Identification;
package SP renames System.Parameters;
package ST renames System.Tasking;
package STR renames System.Tasking.Rendezvous;
package STI renames System.Tasking.Initialization;
package STU renames System.Tasking.Utilities;
package STPO renames System.Task_Primitives.Operations;
package STPOD renames System.Task_Primitives.Operations.DEC;
AST_Lock : aliased System.Task_Primitives.RTS_Lock;
-- This is a global lock; it is used to execute in mutual exclusion
-- from all other AST tasks. It is only used by Lock_AST and
-- Unlock_AST.
procedure Lock_AST (Self_ID : ST.Task_Id);
-- Locks out other AST tasks. Preceding a section of code by Lock_AST and
-- following it by Unlock_AST creates a critical region.
procedure Unlock_AST (Self_ID : ST.Task_Id);
-- Releases lock previously set by call to Lock_AST.
-- All nested locks must be released before other tasks competing for the
-- tasking lock are released.
--------------
-- Lock_AST --
--------------
procedure Lock_AST (Self_ID : ST.Task_Id) is
begin
STI.Defer_Abort_Nestable (Self_ID);
STPO.Write_Lock (AST_Lock'Access, Global_Lock => True);
end Lock_AST;
----------------
-- Unlock_AST --
----------------
procedure Unlock_AST (Self_ID : ST.Task_Id) is
begin
STPO.Unlock (AST_Lock'Access, Global_Lock => True);
STI.Undefer_Abort_Nestable (Self_ID);
end Unlock_AST;
---------------------------------
-- AST_Handler Data Structures --
---------------------------------
-- As noted in the private part of the spec of System.Aux_DEC, the
-- AST_Handler type is simply a pointer to a procedure that takes
-- a single 64bit parameter. The following is a local copy
-- of that definition.
-- We need our own copy because we need to get our hands on this
-- and we cannot see the private part of System.Aux_DEC. We don't
-- want to be a child of Aux_Dec because of complications resulting
-- from the use of pragma Extend_System. We will use unchecked
-- conversions between the two versions of the declarations.
type AST_Handler is access procedure (Param : Long_Integer);
-- However, this declaration is somewhat misleading, since the values
-- referenced by AST_Handler values (all produced in this package by
-- calls to Create_AST_Handler) are highly stylized.
-- The first point is that in VMS/I64, procedure pointers do not in
-- fact point to code, but rather to a procedure descriptor.
-- So a value of type AST_Handler is in fact a pointer to one of
-- descriptors.
type Descriptor_Type is
record
Entry_Point : System.Address;
GP_Value : System.Address;
end record;
for Descriptor_Type'Alignment use Standard'Maximum_Alignment;
-- pragma Warnings (Off, Descriptor_Type);
-- Suppress harmless warnings about alignment.
-- Should explain why this warning is harmless ???
type Descriptor_Ref is access all Descriptor_Type;
-- Normally, there is only one such descriptor for a given procedure, but
-- it works fine to make a copy of the single allocated descriptor, and
-- use the copy itself, and we take advantage of this in the design here.
-- The idea is that AST_Handler values will all point to a record with the
-- following structure:
-- Note: When we say it works fine, there is one delicate point, which
-- is that the code for the AST procedure itself requires the original
-- descriptor address. We handle this by saving the orignal descriptor
-- address in this structure and restoring in Process_AST.
type AST_Handler_Data is record
Descriptor : Descriptor_Type;
Original_Descriptor_Ref : Descriptor_Ref;
Taskid : ATID.Task_Id;
Entryno : Natural;
end record;
type AST_Handler_Data_Ref is access all AST_Handler_Data;
function To_AST_Handler is new Ada.Unchecked_Conversion
(AST_Handler_Data_Ref, System.Aux_DEC.AST_Handler);
-- Each time Create_AST_Handler is called, a new value of this record
-- type is created, containing a copy of the procedure descriptor for
-- the routine used to handle all AST's (Process_AST), and the Task_Id
-- and entry number parameters identifying the task entry involved.
-- The AST_Handler value returned is a pointer to this record. Since
-- the record starts with the procedure descriptor, it can be used
-- by the system in the normal way to call the procedure. But now
-- when the procedure gets control, it can determine the address of
-- the procedure descriptor used to call it (since the ABI specifies
-- that this is left sitting in register r27 on entry), and then use
-- that address to retrieve the Task_Id and entry number so that it
-- knows on which entry to queue the AST request.
-- The next issue is where are these records placed. Since we intend
-- to pass pointers to these records to asynchronous system service
-- routines, they have to be on the heap, which means we have to worry
-- about when to allocate them and deallocate them.
-- We solve this problem by introducing a task attribute that points to
-- a vector, indexed by the entry number, of AST_Handler_Data records
-- for a given task. The pointer itself is a controlled object allowing
-- us to write a finalization routine that frees the referenced vector.
-- An entry in this vector is either initialized (Entryno non-zero) and
-- can be used for any subsequent reference to the same entry, or it is
-- unused, marked by the Entryno value being zero.
type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data;
type AST_Handler_Vector_Ref is access all AST_Handler_Vector;
type AST_Vector_Ptr is new Ada.Finalization.Controlled with record
Vector : AST_Handler_Vector_Ref;
end record;
procedure Finalize (Obj : in out AST_Vector_Ptr);
-- Override Finalize so that the AST Vector gets freed.
procedure Finalize (Obj : in out AST_Vector_Ptr) is
procedure Free is new
Ada.Unchecked_Deallocation (AST_Handler_Vector, AST_Handler_Vector_Ref);
begin
if Obj.Vector /= null then
Free (Obj.Vector);
end if;
end Finalize;
AST_Vector_Init : AST_Vector_Ptr;
-- Initial value, treated as constant, Vector will be null
package AST_Attribute is new Ada.Task_Attributes
(Attribute => AST_Vector_Ptr,
Initial_Value => AST_Vector_Init);
use AST_Attribute;
-----------------------
-- AST Service Queue --
-----------------------
-- The following global data structures are used to queue pending
-- AST requests. When an AST is signalled, the AST service routine
-- Process_AST is called, and it makes an entry in this structure.
type AST_Instance is record
Taskid : ATID.Task_Id;
Entryno : Natural;
Param : Long_Integer;
end record;
-- The Taskid and Entryno indicate the entry on which this AST is to
-- be queued, and Param is the parameter provided from the AST itself.
AST_Service_Queue_Size : constant := 256;
AST_Service_Queue_Limit : constant := 250;
type AST_Service_Queue_Index is mod AST_Service_Queue_Size;
-- Index used to refer to entries in the circular buffer which holds
-- active AST_Instance values. The upper bound reflects the maximum
-- number of AST instances that can be stored in the buffer. Since
-- these entries are immediately serviced by the high priority server
-- task that does the actual entry queuing, it is very unusual to have
-- any significant number of entries simulaneously queued.
AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance;
pragma Volatile_Components (AST_Service_Queue);
-- The circular buffer used to store active AST requests
AST_Service_Queue_Put : AST_Service_Queue_Index := 0;
AST_Service_Queue_Get : AST_Service_Queue_Index := 0;
pragma Atomic (AST_Service_Queue_Put);
pragma Atomic (AST_Service_Queue_Get);
-- These two variables point to the next slots in the AST_Service_Queue
-- to be used for putting a new entry in and taking an entry out. This
-- is a circular buffer, so these pointers wrap around. If the two values
-- are equal the buffer is currently empty. The pointers are atomic to
-- ensure proper synchronization between the single producer (namely the
-- Process_AST procedure), and the single consumer (the AST_Service_Task).
--------------------------------
-- AST Server Task Structures --
--------------------------------
-- The basic approach is that when an AST comes in, a call is made to
-- the Process_AST procedure. It queues the request in the service queue
-- and then wakes up an AST server task to perform the actual call to the
-- required entry. We use this intermediate server task, since the AST
-- procedure itself cannot wait to return, and we need some caller for
-- the rendezvous so that we can use the normal rendezvous mechanism.
-- It would work to have only one AST server task, but then we would lose
-- all overlap in AST processing, and furthermore, we could get priority
-- inversion effects resulting in starvation of AST requests.
-- We therefore maintain a small pool of AST server tasks. We adjust
-- the size of the pool dynamically to reflect traffic, so that we have
-- a sufficient number of server tasks to avoid starvation.
Max_AST_Servers : constant Natural := 16;
-- Maximum number of AST server tasks that can be allocated
Num_AST_Servers : Natural := 0;
-- Number of AST server tasks currently active
Num_Waiting_AST_Servers : Natural := 0;
-- This is the number of AST server tasks that are either waiting for
-- work, or just about to go to sleep and wait for work.
Is_Waiting : array (1 .. Max_AST_Servers) of Boolean := (others => False);
-- An array of flags showing which AST server tasks are currently waiting
AST_Task_Ids : array (1 .. Max_AST_Servers) of ST.Task_Id;
-- Task Id's of allocated AST server tasks
task type AST_Server_Task (Num : Natural) is
pragma Priority (Priority'Last);
end AST_Server_Task;
-- Declaration for AST server task. This task has no entries, it is
-- controlled by sleep and wakeup calls at the task primitives level.
type AST_Server_Task_Ptr is access all AST_Server_Task;
-- Type used to allocate server tasks
-----------------------
-- Local Subprograms --
-----------------------
procedure Allocate_New_AST_Server;
-- Allocate an additional AST server task
procedure Process_AST (Param : Long_Integer);
-- This is the central routine for processing all AST's, it is referenced
-- as the code address of all created AST_Handler values. See detailed
-- description in body to understand how it works to have a single such
-- procedure for all AST's even though it does not get any indication of
-- the entry involved passed as an explicit parameter. The single explicit
-- parameter Param is the parameter passed by the system with the AST.
-----------------------------
-- Allocate_New_AST_Server --
-----------------------------
procedure Allocate_New_AST_Server is
Dummy : AST_Server_Task_Ptr;
pragma Unreferenced (Dummy);
begin
if Num_AST_Servers = Max_AST_Servers then
return;
else
-- Note: it is safe to increment Num_AST_Servers immediately, since
-- no one will try to activate this task until it indicates that it
-- is sleeping by setting its entry in Is_Waiting to True.
Num_AST_Servers := Num_AST_Servers + 1;
Dummy := new AST_Server_Task (Num_AST_Servers);
end if;
end Allocate_New_AST_Server;
---------------------
-- AST_Server_Task --
---------------------
task body AST_Server_Task is
Taskid : ATID.Task_Id;
Entryno : Natural;
Param : aliased Long_Integer;
Self_Id : constant ST.Task_Id := ST.Self;
pragma Volatile (Param);
begin
-- By making this task independent of master, when the environment
-- task is finalizing, the AST_Server_Task will be notified that it
-- should terminate.
STU.Make_Independent;
-- Record our task Id for access by Process_AST
AST_Task_Ids (Num) := Self_Id;
-- Note: this entire task operates with the main task lock set, except
-- when it is sleeping waiting for work, or busy doing a rendezvous
-- with an AST server. This lock protects the data structures that
-- are shared by multiple instances of the server task.
Lock_AST (Self_Id);
-- This is the main infinite loop of the task. We go to sleep and
-- wait to be woken up by Process_AST when there is some work to do.
loop
Num_Waiting_AST_Servers := Num_Waiting_AST_Servers + 1;
Unlock_AST (Self_Id);
STI.Defer_Abort (Self_Id);
if SP.Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Self_Id);
Is_Waiting (Num) := True;
Self_Id.Common.State := ST.AST_Server_Sleep;
STPO.Sleep (Self_Id, ST.AST_Server_Sleep);
Self_Id.Common.State := ST.Runnable;
STPO.Unlock (Self_Id);
if SP.Single_Lock then
STPO.Unlock_RTS;
end if;
-- If the process is finalizing, Undefer_Abort will simply end
-- this task.
STI.Undefer_Abort (Self_Id);
-- We are awake, there is something to do!
Lock_AST (Self_Id);
Num_Waiting_AST_Servers := Num_Waiting_AST_Servers - 1;
-- Loop here to service outstanding requests. We are always
-- locked on entry to this loop.
while AST_Service_Queue_Get /= AST_Service_Queue_Put loop
Taskid := AST_Service_Queue (AST_Service_Queue_Get).Taskid;
Entryno := AST_Service_Queue (AST_Service_Queue_Get).Entryno;
Param := AST_Service_Queue (AST_Service_Queue_Get).Param;
AST_Service_Queue_Get := AST_Service_Queue_Get + 1;
-- This is a manual expansion of the normal call simple code
declare
type AA is access all Long_Integer;
P : AA := Param'Unrestricted_Access;
function To_ST_Task_Id is new Ada.Unchecked_Conversion
(ATID.Task_Id, ST.Task_Id);
begin
Unlock_AST (Self_Id);
STR.Call_Simple
(Acceptor => To_ST_Task_Id (Taskid),
E => ST.Task_Entry_Index (Entryno),
Uninterpreted_Data => P'Address);
exception
when E : others =>
System.IO.Put_Line ("%Debugging event");
System.IO.Put_Line (Exception_Name (E) &
" raised when trying to deliver an AST.");
if Exception_Message (E)'Length /= 0 then
System.IO.Put_Line (Exception_Message (E));
end if;
System.IO.Put_Line ("Task type is " & "Receiver_Type");
System.IO.Put_Line ("Task id is " & ATID.Image (Taskid));
end;
Lock_AST (Self_Id);
end loop;
end loop;
end AST_Server_Task;
------------------------
-- Create_AST_Handler --
------------------------
function Create_AST_Handler
(Taskid : ATID.Task_Id;
Entryno : Natural) return System.Aux_DEC.AST_Handler
is
Attr_Ref : Attribute_Handle;
Process_AST_Ptr : constant AST_Handler := Process_AST'Access;
-- Reference to standard procedure descriptor for Process_AST
function To_Descriptor_Ref is new Ada.Unchecked_Conversion
(AST_Handler, Descriptor_Ref);
Original_Descriptor_Ref : constant Descriptor_Ref :=
To_Descriptor_Ref (Process_AST_Ptr);
begin
if ATID.Is_Terminated (Taskid) then
raise Program_Error;
end if;
Attr_Ref := Reference (Taskid);
-- Allocate another server if supply is getting low
if Num_Waiting_AST_Servers < 2 then
Allocate_New_AST_Server;
end if;
-- No point in creating more if we have zillions waiting to
-- be serviced.
while AST_Service_Queue_Put - AST_Service_Queue_Get
> AST_Service_Queue_Limit
loop
delay 0.01;
end loop;
-- If no AST vector allocated, or the one we have is too short, then
-- allocate one of right size and initialize all entries except the
-- one we will use to unused. Note that the assignment automatically
-- frees the old allocated table if there is one.
if Attr_Ref.Vector = null
or else Attr_Ref.Vector'Length < Entryno
then
Attr_Ref.Vector := new AST_Handler_Vector (1 .. Entryno);
for E in 1 .. Entryno loop
Attr_Ref.Vector (E).Descriptor.Entry_Point :=
Original_Descriptor_Ref.Entry_Point;
Attr_Ref.Vector (E).Descriptor.GP_Value :=
Attr_Ref.Vector (E)'Address;
Attr_Ref.Vector (E).Original_Descriptor_Ref :=
Original_Descriptor_Ref;
Attr_Ref.Vector (E).Taskid := Taskid;
Attr_Ref.Vector (E).Entryno := E;
end loop;
end if;
return To_AST_Handler (Attr_Ref.Vector (Entryno)'Unrestricted_Access);
end Create_AST_Handler;
----------------------------
-- Expand_AST_Packet_Pool --
----------------------------
procedure Expand_AST_Packet_Pool
(Requested_Packets : Natural;
Actual_Number : out Natural;
Total_Number : out Natural)
is
pragma Unreferenced (Requested_Packets);
begin
-- The AST implementation of GNAT does not permit dynamic expansion
-- of the pool, so we simply add no entries and return the total. If
-- it is necessary to expand the allocation, then this package body
-- must be recompiled with a larger value for AST_Service_Queue_Size.
Actual_Number := 0;
Total_Number := AST_Service_Queue_Size;
end Expand_AST_Packet_Pool;
-----------------
-- Process_AST --
-----------------
procedure Process_AST (Param : Long_Integer) is
Handler_Data_Ptr : AST_Handler_Data_Ref;
-- This variable is set to the address of the descriptor through
-- which Process_AST is called. Since the descriptor is part of
-- an AST_Handler value, this is also the address of this value,
-- from which we can obtain the task and entry number information.
function To_Address is new Ada.Unchecked_Conversion
(ST.Task_Id, System.Task_Primitives.Task_Address);
begin
-- Move the contrived GP into place so Taskid and Entryno
-- become available, then restore the true GP.
System.Machine_Code.Asm
(Template => "mov %0 = r1",
Outputs => AST_Handler_Data_Ref'Asm_Output
("=r", Handler_Data_Ptr),
Volatile => True);
System.Machine_Code.Asm
(Template => "ld8 r1 = %0;;",
Inputs => System.Address'Asm_Input
("m", Handler_Data_Ptr.Original_Descriptor_Ref.GP_Value),
Volatile => True);
AST_Service_Queue (AST_Service_Queue_Put) := AST_Instance'
(Taskid => Handler_Data_Ptr.Taskid,
Entryno => Handler_Data_Ptr.Entryno,
Param => Param);
-- OpenVMS Programming Concepts manual, chapter 8.2.3:
-- "Implicit synchronization can be achieved for data that is shared
-- for write by using only AST routines to write the data, since only
-- one AST can be running at any one time."
-- This subprogram runs at AST level so is guaranteed to be
-- called sequentially at a given access level.
AST_Service_Queue_Put := AST_Service_Queue_Put + 1;
-- Need to wake up processing task. If there is no waiting server
-- then we have temporarily run out, but things should still be
-- OK, since one of the active ones will eventually pick up the
-- service request queued in the AST_Service_Queue.
for J in 1 .. Num_AST_Servers loop
if Is_Waiting (J) then
Is_Waiting (J) := False;
-- Sleeps are handled by ASTs on VMS, so don't call Wakeup
STPOD.Interrupt_AST_Handler (To_Address (AST_Task_Ids (J)));
exit;
end if;
end loop;
end Process_AST;
begin
STPO.Initialize_Lock (AST_Lock'Access, STPO.Global_Task_Level);
end System.AST_Handling;
gcc/ada/s-auxdec-vms-ia64.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . A U X _ D E C --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the Itanium/VMS version.
-- The Add,Clear_Interlocked subprograms are dubiously implmented due to
-- the lack of a single bit sync_lock_test_and_set builtin.
-- The "Retry" parameter is ignored due to the lack of retry builtins making
-- the subprograms identical to the non-retry versions.
pragma Style_Checks (All_Checks);
-- Turn off alpha ordering check on subprograms, this unit is laid
-- out to correspond to the declarations in the DEC 83 System unit.
with Interfaces;
package body System.Aux_DEC is
use type Interfaces.Unsigned_8;
------------------------
-- Fetch_From_Address --
------------------------
function Fetch_From_Address (A : Address) return Target is
type T_Ptr is access all Target;
function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
Ptr : constant T_Ptr := To_T_Ptr (A);
begin
return Ptr.all;
end Fetch_From_Address;
-----------------------
-- Assign_To_Address --
-----------------------
procedure Assign_To_Address (A : Address; T : Target) is
type T_Ptr is access all Target;
function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
Ptr : constant T_Ptr := To_T_Ptr (A);
begin
Ptr.all := T;
end Assign_To_Address;
-----------------------
-- Clear_Interlocked --
-----------------------
procedure Clear_Interlocked
(Bit : in out Boolean;
Old_Value : out Boolean)
is
Clr_Bit : Boolean := Bit;
Old_Uns : Interfaces.Unsigned_8;
function Sync_Lock_Test_And_Set
(Ptr : Address;
Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
"__sync_lock_test_and_set_1");
begin
Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0);
Bit := Clr_Bit;
Old_Value := Old_Uns /= 0;
end Clear_Interlocked;
procedure Clear_Interlocked
(Bit : in out Boolean;
Old_Value : out Boolean;
Retry_Count : Natural;
Success_Flag : out Boolean)
is
pragma Unreferenced (Retry_Count);
Clr_Bit : Boolean := Bit;
Old_Uns : Interfaces.Unsigned_8;
function Sync_Lock_Test_And_Set
(Ptr : Address;
Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
"__sync_lock_test_and_set_1");
begin
Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0);
Bit := Clr_Bit;
Old_Value := Old_Uns /= 0;
Success_Flag := True;
end Clear_Interlocked;
---------------------
-- Set_Interlocked --
---------------------
procedure Set_Interlocked
(Bit : in out Boolean;
Old_Value : out Boolean)
is
Set_Bit : Boolean := Bit;
Old_Uns : Interfaces.Unsigned_8;
function Sync_Lock_Test_And_Set
(Ptr : Address;
Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
"__sync_lock_test_and_set_1");
begin
Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1);
Bit := Set_Bit;
Old_Value := Old_Uns /= 0;
end Set_Interlocked;
procedure Set_Interlocked
(Bit : in out Boolean;
Old_Value : out Boolean;
Retry_Count : Natural;
Success_Flag : out Boolean)
is
pragma Unreferenced (Retry_Count);
Set_Bit : Boolean := Bit;
Old_Uns : Interfaces.Unsigned_8;
function Sync_Lock_Test_And_Set
(Ptr : Address;
Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
"__sync_lock_test_and_set_1");
begin
Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1);
Bit := Set_Bit;
Old_Value := Old_Uns /= 0;
Success_Flag := True;
end Set_Interlocked;
---------------------
-- Add_Interlocked --
---------------------
procedure Add_Interlocked
(Addend : Short_Integer;
Augend : in out Aligned_Word;
Sign : out Integer)
is
Overflowed : Boolean := False;
Former : Aligned_Word;
function Sync_Fetch_And_Add
(Ptr : Address;
Value : Short_Integer) return Short_Integer;
pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_2");
begin
Former.Value := Sync_Fetch_And_Add (Augend.Value'Address, Addend);
if Augend.Value < 0 then
Sign := -1;
elsif Augend.Value > 0 then
Sign := 1;
else
Sign := 0;
end if;
if Former.Value > 0 and then Augend.Value <= 0 then
Overflowed := True;
end if;
if Overflowed then
raise Constraint_Error;
end if;
end Add_Interlocked;
----------------
-- Add_Atomic --
----------------
procedure Add_Atomic
(To : in out Aligned_Integer;
Amount : Integer)
is
procedure Sync_Add_And_Fetch
(Ptr : Address;
Value : Integer);
pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4");
begin
Sync_Add_And_Fetch (To.Value'Address, Amount);
end Add_Atomic;
procedure Add_Atomic
(To : in out Aligned_Integer;
Amount : Integer;
Retry_Count : Natural;
Old_Value : out Integer;
Success_Flag : out Boolean)
is
pragma Unreferenced (Retry_Count);
function Sync_Fetch_And_Add
(Ptr : Address;
Value : Integer) return Integer;
pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_4");
begin
Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount);
Success_Flag := True;
end Add_Atomic;
procedure Add_Atomic
(To : in out Aligned_Long_Integer;
Amount : Long_Integer)
is
procedure Sync_Add_And_Fetch
(Ptr : Address;
Value : Long_Integer);
pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_8");
begin
Sync_Add_And_Fetch (To.Value'Address, Amount);
end Add_Atomic;
procedure Add_Atomic
(To : in out Aligned_Long_Integer;
Amount : Long_Integer;
Retry_Count : Natural;
Old_Value : out Long_Integer;
Success_Flag : out Boolean)
is
pragma Unreferenced (Retry_Count);
function Sync_Fetch_And_Add
(Ptr : Address;
Value : Long_Integer) return Long_Integer;
pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_8");
-- Why do we keep importing this over and over again???
begin
Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount);
Success_Flag := True;
end Add_Atomic;
----------------
-- And_Atomic --
----------------
procedure And_Atomic
(To : in out Aligned_Integer;
From : Integer)
is
procedure Sync_And_And_Fetch
(Ptr : Address;
Value : Integer);
pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_4");
begin
Sync_And_And_Fetch (To.Value'Address, From);
end And_Atomic;
procedure And_Atomic
(To : in out Aligned_Integer;
From : Integer;
Retry_Count : Natural;
Old_Value : out Integer;
Success_Flag : out Boolean)
is
pragma Unreferenced (Retry_Count);
function Sync_Fetch_And_And
(Ptr : Address;
Value : Integer) return Integer;
pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_4");
begin
Old_Value := Sync_Fetch_And_And (To.Value'Address, From);
Success_Flag := True;
end And_Atomic;
procedure And_Atomic
(To : in out Aligned_Long_Integer;
From : Long_Integer)
is
procedure Sync_And_And_Fetch
(Ptr : Address;
Value : Long_Integer);
pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_8");
begin
Sync_And_And_Fetch (To.Value'Address, From);
end And_Atomic;
procedure And_Atomic
(To : in out Aligned_Long_Integer;
From : Long_Integer;
Retry_Count : Natural;
Old_Value : out Long_Integer;
Success_Flag : out Boolean)
is
pragma Unreferenced (Retry_Count);
function Sync_Fetch_And_And
(Ptr : Address;
Value : Long_Integer) return Long_Integer;
pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_8");
begin
Old_Value := Sync_Fetch_And_And (To.Value'Address, From);
Success_Flag := True;
end And_Atomic;
---------------
-- Or_Atomic --
---------------
procedure Or_Atomic
(To : in out Aligned_Integer;
From : Integer)
is
procedure Sync_Or_And_Fetch
(Ptr : Address;
Value : Integer);
pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_4");
begin
Sync_Or_And_Fetch (To.Value'Address, From);
end Or_Atomic;
procedure Or_Atomic
(To : in out Aligned_Integer;
From : Integer;
Retry_Count : Natural;
Old_Value : out Integer;
Success_Flag : out Boolean)
is
pragma Unreferenced (Retry_Count);
function Sync_Fetch_And_Or
(Ptr : Address;
Value : Integer) return Integer;
pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_4");
begin
Old_Value := Sync_Fetch_And_Or (To.Value'Address, From);
Success_Flag := True;
end Or_Atomic;
procedure Or_Atomic
(To : in out Aligned_Long_Integer;
From : Long_Integer)
is
procedure Sync_Or_And_Fetch
(Ptr : Address;
Value : Long_Integer);
pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_8");
begin
Sync_Or_And_Fetch (To.Value'Address, From);
end Or_Atomic;
procedure Or_Atomic
(To : in out Aligned_Long_Integer;
From : Long_Integer;
Retry_Count : Natural;
Old_Value : out Long_Integer;
Success_Flag : out Boolean)
is
pragma Unreferenced (Retry_Count);
function Sync_Fetch_And_Or
(Ptr : Address;
Value : Long_Integer) return Long_Integer;
pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_8");
begin
Old_Value := Sync_Fetch_And_Or (To.Value'Address, From);
Success_Flag := True;
end Or_Atomic;
------------
-- Insqhi --
------------
procedure Insqhi
(Item : Address;
Header : Address;
Status : out Insq_Status) is
procedure SYS_PAL_INSQHIL
(STATUS : out Integer; Header : Address; ITEM : Address);
pragma Interface (External, SYS_PAL_INSQHIL);
pragma Import_Valued_Procedure (SYS_PAL_INSQHIL, "SYS$PAL_INSQHIL",
(Integer, Address, Address),
(Value, Value, Value));
Istat : Integer;
begin
SYS_PAL_INSQHIL (Istat, Header, Item);
if Istat = 0 then
Status := OK_Not_First;
elsif Istat = 1 then
Status := OK_First;
else
-- This status is never returned on IVMS
Status := Fail_No_Lock;
end if;
end Insqhi;
------------
-- Remqhi --
------------
procedure Remqhi
(Header : Address;
Item : out Address;
Status : out Remq_Status)
is
-- The removed item is returned in the second function return register,
-- R9 on IVMS. The VMS ABI calls for "small" records to be returned in
-- these registers, so inventing this odd looking record type makes that
-- all work.
type Remq is record
Status : Long_Integer;
Item : Address;
end record;
procedure SYS_PAL_REMQHIL
(Remret : out Remq; Header : Address);
pragma Interface (External, SYS_PAL_REMQHIL);
pragma Import_Valued_Procedure
(SYS_PAL_REMQHIL, "SYS$PAL_REMQHIL",
(Remq, Address),
(Value, Value));
-- Following variables need documentation???
Rstat : Long_Integer;
Remret : Remq;
begin
SYS_PAL_REMQHIL (Remret, Header);
Rstat := Remret.Status;
Item := Remret.Item;
if Rstat = 0 then
Status := Fail_Was_Empty;
elsif Rstat = 1 then
Status := OK_Not_Empty;
elsif Rstat = 2 then
Status := OK_Empty;
else
-- This status is never returned on IVMS
Status := Fail_No_Lock;
end if;
end Remqhi;
------------
-- Insqti --
------------
procedure Insqti
(Item : Address;
Header : Address;
Status : out Insq_Status) is
procedure SYS_PAL_INSQTIL
(STATUS : out Integer; Header : Address; ITEM : Address);
pragma Interface (External, SYS_PAL_INSQTIL);
pragma Import_Valued_Procedure (SYS_PAL_INSQTIL, "SYS$PAL_INSQTIL",
(Integer, Address, Address),
(Value, Value, Value));
Istat : Integer;
begin
SYS_PAL_INSQTIL (Istat, Header, Item);
if Istat = 0 then
Status := OK_Not_First;
elsif Istat = 1 then
Status := OK_First;
else
-- This status is never returned on IVMS
Status := Fail_No_Lock;
end if;
end Insqti;
------------
-- Remqti --
------------
procedure Remqti
(Header : Address;
Item : out Address;
Status : out Remq_Status)
is
-- The removed item is returned in the second function return register,
-- R9 on IVMS. The VMS ABI calls for "small" records to be returned in
-- these registers, so inventing (where is rest of this comment???)
type Remq is record
Status : Long_Integer;
Item : Address;
end record;
procedure SYS_PAL_REMQTIL
(Remret : out Remq; Header : Address);
pragma Interface (External, SYS_PAL_REMQTIL);
pragma Import_Valued_Procedure (SYS_PAL_REMQTIL, "SYS$PAL_REMQTIL",
(Remq, Address),
(Value, Value));
Rstat : Long_Integer;
Remret : Remq;
begin
SYS_PAL_REMQTIL (Remret, Header);
Rstat := Remret.Status;
Item := Remret.Item;
-- Wouldn't case be nicer here, and in previous similar cases ???
if Rstat = 0 then
Status := Fail_Was_Empty;
elsif Rstat = 1 then
Status := OK_Not_Empty;
elsif Rstat = 2 then
Status := OK_Empty;
else
-- This status is never returned on IVMS
Status := Fail_No_Lock;
end if;
end Remqti;
end System.Aux_DEC;
gcc/ada/s-memory-vms_64.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . M E M O R Y --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the VMS 64 bit implementation of this package
-- This implementation assumes that the underlying malloc/free/realloc
-- implementation is thread safe, and thus, no additional lock is required.
-- Note that we still need to defer abort because on most systems, an
-- asynchronous signal (as used for implementing asynchronous abort of
-- task) cannot safely be handled while malloc is executing.
-- If you are not using Ada constructs containing the "abort" keyword, then
-- you can remove the calls to Abort_Defer.all and Abort_Undefer.all from
-- this unit.
pragma Compiler_Unit;
with Ada.Exceptions;
with System.Soft_Links;
with System.Parameters;
with System.CRTL;
package body System.Memory is
use Ada.Exceptions;
use System.Soft_Links;
function c_malloc (Size : System.CRTL.size_t) return System.Address
renames System.CRTL.malloc;
procedure c_free (Ptr : System.Address)
renames System.CRTL.free;
function c_realloc
(Ptr : System.Address; Size : System.CRTL.size_t) return System.Address
renames System.CRTL.realloc;
Gnat_Heap_Size : Integer;
pragma Import (C, Gnat_Heap_Size, "__gl_heap_size");
-- Set by Feature logical GNAT$NO_MALLOC_64 and/or Binder switch -Hnn
-----------
-- Alloc --
-----------
function Alloc (Size : size_t) return System.Address is
Result : System.Address;
Actual_Size : size_t := Size;
begin
if Gnat_Heap_Size = 32 then
return Alloc32 (Size);
end if;
if Size = size_t'Last then
Raise_Exception (Storage_Error'Identity, "object too large");
end if;
-- Change size from zero to non-zero. We still want a proper pointer
-- for the zero case because pointers to zero length objects have to
-- be distinct, but we can't just go ahead and allocate zero bytes,
-- since some malloc's return zero for a zero argument.
if Size = 0 then
Actual_Size := 1;
end if;
if Parameters.No_Abort then
Result := c_malloc (System.CRTL.size_t (Actual_Size));
else
Abort_Defer.all;
Result := c_malloc (System.CRTL.size_t (Actual_Size));
Abort_Undefer.all;
end if;
if Result = System.Null_Address then
Raise_Exception (Storage_Error'Identity, "heap exhausted");
end if;
return Result;
end Alloc;
-------------
-- Alloc32 --
-------------
function Alloc32 (Size : size_t) return System.Address is
Result : System.Address;
Actual_Size : size_t := Size;
begin
if Size = size_t'Last then
Raise_Exception (Storage_Error'Identity, "object too large");
end if;
-- Change size from zero to non-zero. We still want a proper pointer
-- for the zero case because pointers to zero length objects have to
-- be distinct, but we can't just go ahead and allocate zero bytes,
-- since some malloc's return zero for a zero argument.
if Size = 0 then
Actual_Size := 1;
end if;
if Parameters.No_Abort then
Result := C_malloc32 (Actual_Size);
else
Abort_Defer.all;
Result := C_malloc32 (Actual_Size);
Abort_Undefer.all;
end if;
if Result = System.Null_Address then
Raise_Exception (Storage_Error'Identity, "heap exhausted");
end if;
return Result;
end Alloc32;
----------
-- Free --
----------
procedure Free (Ptr : System.Address) is
begin
if Parameters.No_Abort then
c_free (Ptr);
else
Abort_Defer.all;
c_free (Ptr);
Abort_Undefer.all;
end if;
end Free;
-------------
-- Realloc --
-------------
function Realloc
(Ptr : System.Address;
Size : size_t)
return System.Address
is
Result : System.Address;
Actual_Size : constant size_t := Size;
begin
if Gnat_Heap_Size = 32 then
return Realloc32 (Ptr, Size);
end if;
if Size = size_t'Last then
Raise_Exception (Storage_Error'Identity, "object too large");
end if;
if Parameters.No_Abort then
Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size));
else
Abort_Defer.all;
Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size));
Abort_Undefer.all;
end if;
if Result = System.Null_Address then
Raise_Exception (Storage_Error'Identity, "heap exhausted");
end if;
return Result;
end Realloc;
---------------
-- Realloc32 --
---------------
function Realloc32
(Ptr : System.Address;
Size : size_t)
return System.Address
is
Result : System.Address;
Actual_Size : constant size_t := Size;
begin
if Size = size_t'Last then
Raise_Exception (Storage_Error'Identity, "object too large");
end if;
if Parameters.No_Abort then
Result := C_realloc32 (Ptr, Actual_Size);
else
Abort_Defer.all;
Result := C_realloc32 (Ptr, Actual_Size);
Abort_Undefer.all;
end if;
if Result = System.Null_Address then
Raise_Exception (Storage_Error'Identity, "heap exhausted");
end if;
return Result;
end Realloc32;
end System.Memory;
gcc/ada/s-memory-vms_64.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . M E M O R Y --
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides the low level memory allocation/deallocation
-- mechanisms used by GNAT for VMS 64 bit.
-- To provide an alternate implementation, simply recompile the modified
-- body of this package with gnatmake -u -a -g s-memory.adb and make sure
-- that the ali and object files for this unit are found in the object
-- search path.
-- This unit may be used directly from an application program by providing
-- an appropriate WITH, and the interface can be expected to remain stable.
pragma Compiler_Unit;
package System.Memory is
pragma Elaborate_Body;
type size_t is mod 2 ** Standard'Address_Size;
-- Note: the reason we redefine this here instead of using the
-- definition in Interfaces.C is that we do not want to drag in
-- all of Interfaces.C just because System.Memory is used.
function Alloc (Size : size_t) return System.Address;
-- This is the low level allocation routine. Given a size in storage
-- units, it returns the address of a maximally aligned block of
-- memory. The implementation of this routine is guaranteed to be
-- task safe, and also aborts are deferred if necessary.
--
-- If size_t is set to size_t'Last on entry, then a Storage_Error
-- exception is raised with a message "object too large".
--
-- If size_t is set to zero on entry, then a minimal (but non-zero)
-- size block is allocated.
--
-- Note: this is roughly equivalent to the standard C malloc call
-- with the additional semantics as described above.
function Alloc32 (Size : size_t) return System.Address;
-- Equivalent to Alloc except on VMS 64 bit where it invokes
-- 32 bit malloc.
procedure Free (Ptr : System.Address);
-- This is the low level free routine. It frees a block previously
-- allocated with a call to Alloc. As in the case of Alloc, this
-- call is guaranteed task safe, and aborts are deferred.
--
-- Note: this is roughly equivalent to the standard C free call
-- with the additional semantics as described above.
function Realloc
(Ptr : System.Address;
Size : size_t) return System.Address;
-- This is the low level reallocation routine. It takes an existing
-- block address returned by a previous call to Alloc or Realloc,
-- and reallocates the block. The size can either be increased or
-- decreased. If possible the reallocation is done in place, so that
-- the returned result is the same as the value of Ptr on entry.
-- However, it may be necessary to relocate the block to another
-- address, in which case the information is copied to the new
-- block, and the old block is freed. The implementation of this
-- routine is guaranteed to be task safe, and also aborts are
-- deferred as necessary.
--
-- If size_t is set to size_t'Last on entry, then a Storage_Error
-- exception is raised with a message "object too large".
--
-- If size_t is set to zero on entry, then a minimal (but non-zero)
-- size block is allocated.
--
-- Note: this is roughly equivalent to the standard C realloc call
-- with the additional semantics as described above.
function Realloc32
(Ptr : System.Address;
Size : size_t) return System.Address;
-- Equivalent to Realloc except on VMS 64 bit where it invokes
-- 32 bit realloc.
private
-- The following names are used from the generated compiler code
pragma Export (C, Alloc, "__gnat_malloc");
pragma Export (C, Alloc32, "__gnat_malloc32");
pragma Export (C, Free, "__gnat_free");
pragma Export (C, Realloc, "__gnat_realloc");
pragma Export (C, Realloc32, "__gnat_realloc32");
function C_malloc32 (Size : size_t) return System.Address;
pragma Import (C, C_malloc32, "_malloc32");
-- An alias for malloc for allocating 32bit memory on 64bit VMS
function C_realloc32
(Ptr : System.Address;
Size : size_t) return System.Address;
pragma Import (C, C_realloc32, "_realloc32");
-- An alias for realloc for allocating 32bit memory on 64bit VMS
end System.Memory;
gcc/ada/s-osinte-vms-ia64.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . O S _ I N T E R F A C E --
-- --
-- B o d y --
-- --
-- Copyright (C) 2003-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a OpenVMS/IA64 version of this package
-- This package encapsulates all direct interfaces to OS services
-- that are needed by children of System.
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 Interfaces.C; use Interfaces.C;
package body System.OS_Interface is
-----------------
-- sched_yield --
-----------------
function sched_yield return int is
procedure sched_yield_base;
pragma Import (C, sched_yield_base, "PTHREAD_YIELD_NP");
begin
sched_yield_base;
return 0;
end sched_yield;
end System.OS_Interface;
gcc/ada/s-osinte-vms-ia64.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . O S _ I N T E R F A C E --
-- --
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a OpenVMS/IA64 version of this package
-- This package encapsulates all direct interfaces to OS services
-- that are needed by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
with Interfaces.C;
with Ada.Unchecked_Conversion;
with System.Aux_DEC;
package System.OS_Interface is
pragma Preelaborate;
pragma Linker_Options ("--for-linker=ia64$library:pthread$rtl.exe");
-- Link in the DEC threads library
-- pragma Linker_Options ("--for-linker=/threads_enable");
-- Enable upcalls and multiple kernel threads.
subtype int is Interfaces.C.int;
subtype short is Interfaces.C.short;
subtype long is Interfaces.C.long;
subtype unsigned is Interfaces.C.unsigned;
subtype unsigned_short is Interfaces.C.unsigned_short;
subtype unsigned_long is Interfaces.C.unsigned_long;
subtype unsigned_char is Interfaces.C.unsigned_char;
subtype plain_char is Interfaces.C.plain_char;
subtype size_t is Interfaces.C.size_t;
-----------------------------
-- Signals (Interrupt IDs) --
-----------------------------
-- Type signal has an arbitrary limit of 31
Max_Interrupt : constant := 31;
type Signal is new unsigned range 0 .. Max_Interrupt;
for Signal'Size use unsigned'Size;
type sigset_t is array (Signal) of Boolean;
pragma Pack (sigset_t);
-- Interrupt_Number_Type
-- Unsigned long integer denoting the number of an interrupt
subtype Interrupt_Number_Type is unsigned_long;
-- OpenVMS system services return values of type Cond_Value_Type
subtype Cond_Value_Type is unsigned_long;
subtype Short_Cond_Value_Type is unsigned_short;
type IO_Status_Block_Type is record
Status : Short_Cond_Value_Type;
Count : unsigned_short;
Dev_Info : unsigned_long;
end record;
type AST_Handler is access procedure (Param : Address);
pragma Convention (C, AST_Handler);
No_AST_Handler : constant AST_Handler := null;
CMB_M_READONLY : constant := 16#00000001#;
CMB_M_WRITEONLY : constant := 16#00000002#;
AGN_M_READONLY : constant := 16#00000001#;
AGN_M_WRITEONLY : constant := 16#00000002#;
IO_WRITEVBLK : constant := 48; -- WRITE VIRTUAL BLOCK
IO_READVBLK : constant := 49; -- READ VIRTUAL BLOCK
----------------
-- Sys_Assign --
----------------
--
-- Assign I/O Channel
--
-- Status = returned status
-- Devnam = address of device name or logical name string
-- descriptor
-- Chan = address of word to receive channel number assigned
-- Acmode = access mode associated with channel
-- Mbxnam = address of mailbox logical name string descriptor, if
-- mailbox associated with device
-- Flags = optional channel flags longword for specifying options
-- for the $ASSIGN operation
--
procedure Sys_Assign
(Status : out Cond_Value_Type;
Devnam : String;
Chan : out unsigned_short;
Acmode : unsigned_short := 0;
Mbxnam : String := String'Null_Parameter;
Flags : unsigned_long := 0);
pragma Interface (External, Sys_Assign);
pragma Import_Valued_Procedure
(Sys_Assign, "SYS$ASSIGN",
(Cond_Value_Type, String, unsigned_short,
unsigned_short, String, unsigned_long),
(Value, Descriptor (s), Reference,
Value, Descriptor (s), Value),
Flags);
----------------
-- Sys_Cantim --
----------------
--
-- Cancel Timer
--
-- Status = returned status
-- Reqidt = ID of timer to be cancelled
-- Acmode = Access mode
--
procedure Sys_Cantim
(Status : out Cond_Value_Type;
Reqidt : Address;
Acmode : unsigned);
pragma Interface (External, Sys_Cantim);
pragma Import_Valued_Procedure
(Sys_Cantim, "SYS$CANTIM",
(Cond_Value_Type, Address, unsigned),
(Value, Value, Value));
----------------
-- Sys_Crembx --
----------------
--
-- Create mailbox
--
-- Status = returned status
-- Prmflg = permanent flag
-- Chan = channel
-- Maxmsg = maximum message
-- Bufquo = buufer quote
-- Promsk = protection mast
-- Acmode = access mode
-- Lognam = logical name
-- Flags = flags
--
procedure Sys_Crembx
(Status : out Cond_Value_Type;
Prmflg : unsigned_char;
Chan : out unsigned_short;
Maxmsg : unsigned_long := 0;
Bufquo : unsigned_long := 0;
Promsk : unsigned_short := 0;
Acmode : unsigned_short := 0;
Lognam : String;
Flags : unsigned_long := 0);
pragma Interface (External, Sys_Crembx);
pragma Import_Valued_Procedure
(Sys_Crembx, "SYS$CREMBX",
(Cond_Value_Type, unsigned_char, unsigned_short,
unsigned_long, unsigned_long, unsigned_short,
unsigned_short, String, unsigned_long),
(Value, Value, Reference,
Value, Value, Value,
Value, Descriptor (s), Value));
-------------
-- Sys_QIO --
-------------
--
-- Queue I/O
--
-- Status = Returned status of call
-- EFN = event flag to be set when I/O completes
-- Chan = channel
-- Func = function
-- Iosb = I/O status block
-- Astadr = system trap to be generated when I/O completes
-- Astprm = AST parameter
-- P1-6 = optional parameters
procedure Sys_QIO
(Status : out Cond_Value_Type;
EFN : unsigned_long := 0;
Chan : unsigned_short;
Func : unsigned_long := 0;
Iosb : out IO_Status_Block_Type;
Astadr : AST_Handler := No_AST_Handler;
Astprm : Address := Null_Address;
P1 : unsigned_long := 0;
P2 : unsigned_long := 0;
P3 : unsigned_long := 0;
P4 : unsigned_long := 0;
P5 : unsigned_long := 0;
P6 : unsigned_long := 0);
procedure Sys_QIO
(Status : out Cond_Value_Type;
EFN : unsigned_long := 0;
Chan : unsigned_short;
Func : unsigned_long := 0;
Iosb : Address := Null_Address;
Astadr : AST_Handler := No_AST_Handler;
Astprm : Address := Null_Address;
P1 : unsigned_long := 0;
P2 : unsigned_long := 0;
P3 : unsigned_long := 0;
P4 : unsigned_long := 0;
P5 : unsigned_long := 0;
P6 : unsigned_long := 0);
pragma Interface (External, Sys_QIO);
pragma Import_Valued_Procedure
(Sys_QIO, "SYS$QIO",
(Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long,
IO_Status_Block_Type, AST_Handler, Address,
unsigned_long, unsigned_long, unsigned_long,
unsigned_long, unsigned_long, unsigned_long),
(Value, Value, Value, Value,
Reference, Value, Value,
Value, Value, Value,
Value, Value, Value));
pragma Import_Valued_Procedure
(Sys_QIO, "SYS$QIO",
(Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long,
Address, AST_Handler, Address,
unsigned_long, unsigned_long, unsigned_long,
unsigned_long, unsigned_long, unsigned_long),
(Value, Value, Value, Value,
Value, Value, Value,
Value, Value, Value,
Value, Value, Value));
----------------
-- Sys_Setimr --
----------------
--
-- Set Timer
--
-- Status = Returned status of call
-- EFN = event flag to be set when timer expires
-- Tim = expiration time
-- AST = system trap to be generated when timer expires
-- Redidt = returned ID of timer (e.g. to cancel timer)
-- Flags = flags
--
procedure Sys_Setimr
(Status : out Cond_Value_Type;
EFN : unsigned_long;
Tim : Long_Integer;
AST : AST_Handler;
Reqidt : Address;
Flags : unsigned_long);
pragma Interface (External, Sys_Setimr);
pragma Import_Valued_Procedure
(Sys_Setimr, "SYS$SETIMR",
(Cond_Value_Type, unsigned_long, Long_Integer,
AST_Handler, Address, unsigned_long),
(Value, Value, Reference,
Value, Value, Value));
Interrupt_ID_0 : constant := 0;
Interrupt_ID_1 : constant := 1;
Interrupt_ID_2 : constant := 2;
Interrupt_ID_3 : constant := 3;
Interrupt_ID_4 : constant := 4;
Interrupt_ID_5 : constant := 5;
Interrupt_ID_6 : constant := 6;
Interrupt_ID_7 : constant := 7;
Interrupt_ID_8 : constant := 8;
Interrupt_ID_9 : constant := 9;
Interrupt_ID_10 : constant := 10;
Interrupt_ID_11 : constant := 11;
Interrupt_ID_12 : constant := 12;
Interrupt_ID_13 : constant := 13;
Interrupt_ID_14 : constant := 14;
Interrupt_ID_15 : constant := 15;
Interrupt_ID_16 : constant := 16;
Interrupt_ID_17 : constant := 17;
Interrupt_ID_18 : constant := 18;
Interrupt_ID_19 : constant := 19;
Interrupt_ID_20 : constant := 20;
Interrupt_ID_21 : constant := 21;
Interrupt_ID_22 : constant := 22;
Interrupt_ID_23 : constant := 23;
Interrupt_ID_24 : constant := 24;
Interrupt_ID_25 : constant := 25;
Interrupt_ID_26 : constant := 26;
Interrupt_ID_27 : constant := 27;
Interrupt_ID_28 : constant := 28;
Interrupt_ID_29 : constant := 29;
Interrupt_ID_30 : constant := 30;
Interrupt_ID_31 : constant := 31;
-----------
-- Errno --
-----------
function errno return int;
pragma Import (C, errno, "__get_errno");
EINTR : constant := 4; -- Interrupted system call
EAGAIN : constant := 11; -- No more processes
ENOMEM : constant := 12; -- Not enough core
-------------------------
-- Priority Scheduling --
-------------------------
SCHED_FIFO : constant := 1;
SCHED_RR : constant := 2;
SCHED_OTHER : constant := 3;
SCHED_BG : constant := 4;
SCHED_LFI : constant := 5;
SCHED_LRR : constant := 6;
-------------
-- Process --
-------------
type pid_t is private;
function kill (pid : pid_t; sig : Signal) return int;
pragma Import (C, kill);
function getpid return pid_t;
pragma Import (C, getpid);
-------------
-- Threads --
-------------
type Thread_Body is access
function (arg : System.Address) return System.Address;
pragma Convention (C, Thread_Body);
function Thread_Body_Access is new
Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, Thread_Body);
type pthread_t is private;
subtype Thread_Id is pthread_t;
type pthread_mutex_t is limited private;
type pthread_cond_t is limited private;
type pthread_attr_t is limited private;
type pthread_mutexattr_t is limited private;
type pthread_condattr_t is limited private;
type pthread_key_t is private;
PTHREAD_CREATE_JOINABLE : constant := 0;
PTHREAD_CREATE_DETACHED : constant := 1;
PTHREAD_CANCEL_DISABLE : constant := 0;
PTHREAD_CANCEL_ENABLE : constant := 1;
PTHREAD_CANCEL_DEFERRED : constant := 0;
PTHREAD_CANCEL_ASYNCHRONOUS : constant := 1;
-- Don't use ERRORCHECK mutexes, they don't work when a thread is not
-- the owner. AST's, at least, unlock others threads mutexes. Even
-- if the error is ignored, they don't work.
PTHREAD_MUTEX_NORMAL_NP : constant := 0;
PTHREAD_MUTEX_RECURSIVE_NP : constant := 1;
PTHREAD_MUTEX_ERRORCHECK_NP : constant := 2;
PTHREAD_INHERIT_SCHED : constant := 0;
PTHREAD_EXPLICIT_SCHED : constant := 1;
function pthread_cancel (thread : pthread_t) return int;
pragma Import (C, pthread_cancel, "PTHREAD_CANCEL");
procedure pthread_testcancel;
pragma Import (C, pthread_testcancel, "PTHREAD_TESTCANCEL");
function pthread_setcancelstate
(newstate : int; oldstate : access int) return int;
pragma Import (C, pthread_setcancelstate, "PTHREAD_SETCANCELSTATE");
function pthread_setcanceltype
(newtype : int; oldtype : access int) return int;
pragma Import (C, pthread_setcanceltype, "PTHREAD_SETCANCELTYPE");
-------------------------
-- POSIX.1c Section 3 --
-------------------------
function pthread_lock_global_np return int;
pragma Import (C, pthread_lock_global_np, "PTHREAD_LOCK_GLOBAL_NP");
function pthread_unlock_global_np return int;
pragma Import (C, pthread_unlock_global_np, "PTHREAD_UNLOCK_GLOBAL_NP");
--------------------------
-- POSIX.1c Section 11 --
--------------------------
function pthread_mutexattr_init
(attr : access pthread_mutexattr_t) return int;
pragma Import (C, pthread_mutexattr_init, "PTHREAD_MUTEXATTR_INIT");
function pthread_mutexattr_destroy
(attr : access pthread_mutexattr_t) return int;
pragma Import (C, pthread_mutexattr_destroy, "PTHREAD_MUTEXATTR_DESTROY");
function pthread_mutexattr_settype_np
(attr : access pthread_mutexattr_t;
mutextype : int) return int;
pragma Import (C, pthread_mutexattr_settype_np,
"PTHREAD_MUTEXATTR_SETTYPE_NP");
function pthread_mutex_init
(mutex : access pthread_mutex_t;
attr : access pthread_mutexattr_t) return int;
pragma Import (C, pthread_mutex_init, "PTHREAD_MUTEX_INIT");
function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_mutex_destroy, "PTHREAD_MUTEX_DESTROY");
function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_mutex_lock, "PTHREAD_MUTEX_LOCK");
function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_mutex_unlock, "PTHREAD_MUTEX_UNLOCK");
function pthread_condattr_init
(attr : access pthread_condattr_t) return int;
pragma Import (C, pthread_condattr_init, "PTHREAD_CONDATTR_INIT");
function pthread_condattr_destroy
(attr : access pthread_condattr_t) return int;
pragma Import (C, pthread_condattr_destroy, "PTHREAD_CONDATTR_DESTROY");
function pthread_cond_init
(cond : access pthread_cond_t;
attr : access pthread_condattr_t) return int;
pragma Import (C, pthread_cond_init, "PTHREAD_COND_INIT");
function pthread_cond_destroy (cond : access pthread_cond_t) return int;
pragma Import (C, pthread_cond_destroy, "PTHREAD_COND_DESTROY");
function pthread_cond_signal (cond : access pthread_cond_t) return int;
pragma Import (C, pthread_cond_signal, "PTHREAD_COND_SIGNAL");
function pthread_cond_signal_int_np
(cond : access pthread_cond_t) return int;
pragma Import (C, pthread_cond_signal_int_np,
"PTHREAD_COND_SIGNAL_INT_NP");
function pthread_cond_wait
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_cond_wait, "PTHREAD_COND_WAIT");
--------------------------
-- POSIX.1c Section 13 --
--------------------------
function pthread_mutexattr_setprotocol
(attr : access pthread_mutexattr_t; protocol : int) return int;
pragma Import (C, pthread_mutexattr_setprotocol,
"PTHREAD_MUTEXATTR_SETPROTOCOL");
type struct_sched_param is record
sched_priority : int; -- scheduling priority
end record;
for struct_sched_param'Size use 8*4;
pragma Convention (C, struct_sched_param);
function pthread_setschedparam
(thread : pthread_t;
policy : int;
param : access struct_sched_param) return int;
pragma Import (C, pthread_setschedparam, "PTHREAD_SETSCHEDPARAM");
function pthread_attr_setscope
(attr : access pthread_attr_t;
contentionscope : int) return int;
pragma Import (C, pthread_attr_setscope, "PTHREAD_ATTR_SETSCOPE");
function pthread_attr_setinheritsched
(attr : access pthread_attr_t;
inheritsched : int) return int;
pragma Import (C, pthread_attr_setinheritsched,
"PTHREAD_ATTR_SETINHERITSCHED");
function pthread_attr_setschedpolicy
(attr : access pthread_attr_t; policy : int) return int;
pragma Import (C, pthread_attr_setschedpolicy,
"PTHREAD_ATTR_SETSCHEDPOLICY");
function pthread_attr_setschedparam
(attr : access pthread_attr_t;
sched_param : int) return int;
pragma Import (C, pthread_attr_setschedparam, "PTHREAD_ATTR_SETSCHEDPARAM");
function sched_yield return int;
--------------------------
-- P1003.1c Section 16 --
--------------------------
function pthread_attr_init (attributes : access pthread_attr_t) return int;
pragma Import (C, pthread_attr_init, "PTHREAD_ATTR_INIT");
function pthread_attr_destroy
(attributes : access pthread_attr_t) return int;
pragma Import (C, pthread_attr_destroy, "PTHREAD_ATTR_DESTROY");
function pthread_attr_setdetachstate
(attr : access pthread_attr_t;
detachstate : int) return int;
pragma Import (C, pthread_attr_setdetachstate,
"PTHREAD_ATTR_SETDETACHSTATE");
function pthread_attr_setstacksize
(attr : access pthread_attr_t;
stacksize : size_t) return int;
pragma Import (C, pthread_attr_setstacksize, "PTHREAD_ATTR_SETSTACKSIZE");
function pthread_create
(thread : access pthread_t;
attributes : access pthread_attr_t;
start_routine : Thread_Body;
arg : System.Address) return int;
pragma Import (C, pthread_create, "PTHREAD_CREATE");
procedure pthread_exit (status : System.Address);
pragma Import (C, pthread_exit, "PTHREAD_EXIT");
function pthread_self return pthread_t;
pragma Import (C, pthread_self, "PTHREAD_SELF");
-- ??? This can be inlined, see pthread.h
--------------------------
-- POSIX.1c Section 17 --
--------------------------
function pthread_setspecific
(key : pthread_key_t;
value : System.Address) return int;
pragma Import (C, pthread_setspecific, "PTHREAD_SETSPECIFIC");
function pthread_getspecific (key : pthread_key_t) return System.Address;
pragma Import (C, pthread_getspecific, "PTHREAD_GETSPECIFIC");
type destructor_pointer is access procedure (arg : System.Address);
pragma Convention (C, destructor_pointer);
function pthread_key_create
(key : access pthread_key_t;
destructor : destructor_pointer) return int;
pragma Import (C, pthread_key_create, "PTHREAD_KEY_CREATE");
private
type pid_t is new int;
type pthreadLongAddr_p is mod 2 ** Long_Integer'Size;
type pthreadLongAddr_t is mod 2 ** Long_Integer'Size;
type pthreadLongAddr_t_ptr is mod 2 ** Long_Integer'Size;
type pthreadLongString_t is mod 2 ** Long_Integer'Size;
type pthreadLongUint_t is mod 2 ** Long_Integer'Size;
type pthreadLongUint_array is array (Natural range <>)
of pthreadLongUint_t;
type pthread_t is mod 2 ** Long_Integer'Size;
type pthread_cond_t is record
state : unsigned;
valid : unsigned;
name : pthreadLongString_t;
arg : unsigned;
sequence : unsigned;
block : pthreadLongAddr_t_ptr;
end record;
for pthread_cond_t'Size use 8*32;
pragma Convention (C, pthread_cond_t);
type pthread_attr_t is record
valid : long;
name : pthreadLongString_t;
arg : pthreadLongUint_t;
reserved : pthreadLongUint_array (0 .. 18);
end record;
for pthread_attr_t'Size use 8*176;
pragma Convention (C, pthread_attr_t);
type pthread_mutex_t is record
lock : unsigned;
valid : unsigned;
name : pthreadLongString_t;
arg : unsigned;
sequence : unsigned;
block : pthreadLongAddr_p;
owner : unsigned;
depth : unsigned;
end record;
for pthread_mutex_t'Size use 8*40;
pragma Convention (C, pthread_mutex_t);
type pthread_mutexattr_t is record
valid : long;
reserved : pthreadLongUint_array (0 .. 14);
end record;
for pthread_mutexattr_t'Size use 8*128;
pragma Convention (C, pthread_mutexattr_t);
type pthread_condattr_t is record
valid : long;
reserved : pthreadLongUint_array (0 .. 12);
end record;
for pthread_condattr_t'Size use 8*112;
pragma Convention (C, pthread_condattr_t);
type pthread_key_t is new unsigned;
pragma Inline (pthread_self);
end System.OS_Interface;
gcc/ada/s-tasdeb-vms.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T A S K I N G . D E B U G --
-- --
-- B o d y --
-- --
-- Copyright (C) 2008-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- OpenVMS Version
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with System.Aux_DEC;
with System.CRTL;
with System.Task_Primitives.Operations;
package body System.Tasking.Debug is
package OSI renames System.OS_Interface;
package STPO renames System.Task_Primitives.Operations;
use System.Aux_DEC;
-- Condition value type
subtype Cond_Value_Type is Unsigned_Longword;
type Trace_Flag_Set is array (Character) of Boolean;
Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True);
-- Print_Routine fuction codes
type Print_Functions is
(No_Print, Print_Newline, Print_Control,
Print_String, Print_Symbol, Print_FAO);
for Print_Functions use
(No_Print => 0, Print_Newline => 1, Print_Control => 2,
Print_String => 3, Print_Symbol => 4, Print_FAO => 5);
-- Counted ascii type declarations
subtype Count_Type is Natural range 0 .. 255;
for Count_Type'Object_Size use 8;
type ASCIC (Count : Count_Type) is record
Text : String (1 .. Count);
end record;
for ASCIC use record
Count at 0 range 0 .. 7;
end record;
pragma Pack (ASCIC);
type AASCIC is access ASCIC;
for AASCIC'Size use 32;
type AASCIC_Array is array (Positive range <>) of AASCIC;
type ASCIC127 is record
Count : Count_Type;
Text : String (1 .. 127);
end record;
for ASCIC127 use record
Count at 0 range 0 .. 7;
Text at 1 range 0 .. 127 * 8 - 1;
end record;
-- DEBUG Event record types used to signal DEBUG about Ada events
type Debug_Event_Record is record
Code : Unsigned_Word; -- Event code that uniquely identifies event
Flags : Bit_Array_8; -- Flag bits
-- Bit 0: This event allows a parameter list
-- Bit 1: Parameters are address expressions
Sentinal : Unsigned_Byte; -- Sentinal valuye: Always K_EVENT_SENT
TS_Kind : Unsigned_Byte; -- DST type specification: Always K_TS_TASK
DType : Unsigned_Byte; -- DTYPE of parameter if of atomic data type
-- Always K_DTYPE_TASK
MBZ : Unsigned_Byte; -- Unused (must be zero)
Minchr : Count_Type; -- Minimum chars needed to identify event
Name : ASCIC (31); -- Event name uppercase only
Help : AASCIC; -- Event description
end record;
for Debug_Event_Record use record
Code at 0 range 0 .. 15;
Flags at 2 range 0 .. 7;
Sentinal at 3 range 0 .. 7;
TS_Kind at 4 range 0 .. 7;
Dtype at 5 range 0 .. 7;
MBZ at 6 range 0 .. 7;
Minchr at 7 range 0 .. 7;
Name at 8 range 0 .. 32 * 8 - 1;
Help at 40 range 0 .. 31;
end record;
type Ada_Event_Control_Block_Type is record
Code : Unsigned_Word; -- Reserved and defined by DEBUG
Unused1 : Unsigned_Byte; -- Reserved and defined by DEBUG
Sentinal : Unsigned_Byte; -- Reserved and defined by DEBUG
Facility : Unsigned_Word; -- Reserved and defined by DEBUG
Flags : Unsigned_Word; -- Reserved and defined by DEBUG
Value : Unsigned_Longword; -- Reserved and defined by DEBUG
Unused2 : Unsigned_Longword; -- Reserved and defined by DEBUG
Sigargs : Unsigned_Longword;
P1 : Unsigned_Longword;
Sub_Event : Unsigned_Longword;
end record;
for Ada_Event_Control_Block_Type use record
Code at 0 range 0 .. 15;
Unused1 at 2 range 0 .. 7;
Sentinal at 3 range 0 .. 7;
Facility at 4 range 0 .. 15;
Flags at 6 range 0 .. 15;
Value at 8 range 0 .. 31;
Unused2 at 12 range 0 .. 31;
Sigargs at 16 range 0 .. 31;
P1 at 20 range 0 .. 31;
Sub_Event at 24 range 0 .. 31;
end record;
type Ada_Event_Control_Block_Access is access Ada_Event_Control_Block_Type;
for Ada_Event_Control_Block_Access'Size use 32;
-- Print_Routine_Type with max optional parameters
type Print_Routine_Type is access procedure
(Print_Function : Print_Functions;
Print_Subfunction : Print_Functions;
P1 : Unsigned_Longword := 0;
P2 : Unsigned_Longword := 0;
P3 : Unsigned_Longword := 0;
P4 : Unsigned_Longword := 0;
P5 : Unsigned_Longword := 0;
P6 : Unsigned_Longword := 0);
for Print_Routine_Type'Size use 32;
---------------
-- Constants --
---------------
-- These are used to obtain and convert task values
K_CVT_VALUE_NUM : constant := 1;
K_CVT_NUM_VALUE : constant := 2;
K_NEXT_TASK : constant := 3;
-- These are used to ask ADA to display task information
K_SHOW_TASK : constant := 4;
K_SHOW_STAT : constant := 5;
K_SHOW_DEADLOCK : constant := 6;
-- These are used to get and set various attributes of one or more tasks
-- Task state
-- K_GET_STATE : constant := 7;
-- K_GET_ACTIVE : constant := 8;
-- K_SET_ACTIVE : constant := 9;
K_SET_ABORT : constant := 10;
-- K_SET_HOLD : constant := 11;
-- Task priority
K_GET_PRIORITY : constant := 12;
K_SET_PRIORITY : constant := 13;
K_RESTORE_PRIORITY : constant := 14;
-- Task registers
-- K_GET_REGISTERS : constant := 15;
-- K_SET_REGISTERS : constant := 16;
-- These are used to control definable events
K_ENABLE_EVENT : constant := 17;
K_DISABLE_EVENT : constant := 18;
K_ANNOUNCE_EVENT : constant := 19;
-- These are used to control time-slicing.
-- K_SHOW_TIME_SLICE : constant := 20;
-- K_SET_TIME_SLICE : constant := 21;
-- This is used to symbolize task stack addresses.
-- K_SYMBOLIZE_ADDRESS : constant := 22;
K_GET_CALLER : constant := 23;
-- This is used to obtain the task value of the caller task
-- Miscellaneous functions - see below for details
K_CLEANUP_EVENT : constant := 24;
K_SHOW_EVENT_DEF : constant := 25;
-- K_CHECK_TASK_STACK : constant := 26; -- why commented out ???
-- This is used to obtain the DBGEXT-interface revision level
-- K_GET_DBGEXT_REV : constant := 27; -- why commented out ???
K_GET_STATE_1 : constant := 28;
-- This is used to obtain additional state info, primarily for PCA
K_FIND_EVENT_BY_CODE : constant := 29;
K_FIND_EVENT_BY_NAME : constant := 30;
-- These are used to search for user-defined event entries
-- This is used to stop task schedulding. Why commented out ???
-- K_STOP_ALL_OTHER_TASKS : constant := 31;
-- Debug event constants
K_TASK_NOT_EXIST : constant := 3;
K_SUCCESS : constant := 1;
K_EVENT_SENT : constant := 16#9A#;
K_TS_TASK : constant := 18;
K_DTYPE_TASK : constant := 44;
-- Status signal constants
SS_BADPARAM : constant := 20;
SS_NORMAL : constant := 1;
-- Miscellaneous mask constants
V_EVNT_ALL : constant := 0;
V_Full_Display : constant := 11;
V_Suppress_Header : constant := 13;
-- CMA constants (why are some commented out???)
CMA_C_DEBGET_GUARDSIZE : constant := 1;
CMA_C_DEBGET_IS_HELD : constant := 2;
-- CMA_C_DEBGET_IS_INITIAL : constant := 3;
-- CMA_C_DEBGET_NUMBER : constant := 4;
CMA_C_DEBGET_STACKPTR : constant := 5;
CMA_C_DEBGET_STACK_BASE : constant := 6;
CMA_C_DEBGET_STACK_TOP : constant := 7;
CMA_C_DEBGET_SCHED_STATE : constant := 8;
CMA_C_DEBGET_YELLOWSIZE : constant := 9;
-- CMA_C_DEBGET_BASE_PRIO : constant := 10;
-- CMA_C_DEBGET_REGS : constant := 11;
-- CMA_C_DEBGET_ALT_PENDING : constant := 12;
-- CMA_C_DEBGET_ALT_A_ENABLE : constant := 13;
-- CMA_C_DEBGET_ALT_G_ENABLE : constant := 14;
-- CMA_C_DEBGET_SUBSTATE : constant := 15;
-- CMA_C_DEBGET_OBJECT_ADDR : constant := 16;
-- CMA_C_DEBGET_THKIND : constant := 17;
-- CMA_C_DEBGET_DETACHED : constant := 18;
CMA_C_DEBGET_TCB_SIZE : constant := 19;
-- CMA_C_DEBGET_START_PC : constant := 20;
-- CMA_C_DEBGET_NEXT_PC : constant := 22;
-- CMA_C_DEBGET_POLICY : constant := 23;
-- CMA_C_DEBGET_STACK_YELLOW : constant := 24;
-- CMA_C_DEBGET_STACK_DEFAULT : constant := 25;
-- Miscellaneous counted ascii constants
Star : constant AASCIC := new ASCIC'(2, ("* "));
NoStar : constant AASCIC := new ASCIC'(2, (" "));
Hold : constant AASCIC := new ASCIC'(4, ("HOLD"));
NoHold : constant AASCIC := new ASCIC'(4, (" "));
Header : constant AASCIC := new ASCIC '
(60, (" task id pri hold state substate task object"));
Empty_Text : constant AASCIC := new ASCIC (0);
-- DEBUG Ada tasking states equated to their GNAT tasking equivalents
Ada_State_Invalid_State : constant AASCIC :=
new ASCIC'(17, "Invalid state ");
-- Ada_State_Abnormal : constant AASCIC :=
-- new ASCIC'(17, "Abnormal ");
Ada_State_Aborting : constant AASCIC :=
new ASCIC'(17, "Aborting "); -- Aborting (new)
-- Ada_State_Completed_Abn : constant AASCIC :=
-- new ASCIC'(17, "Completed [abn] ");
-- Ada_State_Completed_Exc : constant AASCIC :=
-- new ASCIC'(17, "Completed [exc] ");
Ada_State_Completed : constant AASCIC :=
new ASCIC'(17, "Completed "); -- Master_Completion_Sleep
Ada_State_Runnable : constant AASCIC :=
new ASCIC'(17, "Runnable "); -- Runnable
Ada_State_Activating : constant AASCIC :=
new ASCIC'(17, "Activating ");
Ada_State_Accept : constant AASCIC :=
new ASCIC'(17, "Accept "); -- Acceptor_Sleep
Ada_State_Select_or_Delay : constant AASCIC :=
new ASCIC'(17, "Select or delay "); -- Acceptor_Delay_Sleep
Ada_State_Select_or_Term : constant AASCIC :=
new ASCIC'(17, "Select or term. "); -- Terminate_Alternative
Ada_State_Select_or_Abort : constant AASCIC :=
new ASCIC'(17, "Select or abort "); -- Async_Select_Sleep (new)
-- Ada_State_Select : constant AASCIC :=
-- new ASCIC'(17, "Select ");
Ada_State_Activating_Tasks : constant AASCIC :=
new ASCIC'(17, "Activating tasks "); -- Activator_Sleep
Ada_State_Delay : constant AASCIC :=
new ASCIC'(17, "Delay "); -- AST_Pending
-- Ada_State_Dependents : constant AASCIC :=
-- new ASCIC'(17, "Dependents ");
Ada_State_Entry_Call : constant AASCIC :=
new ASCIC'(17, "Entry call "); -- Entry_Caller_Sleep
Ada_State_Cond_Entry_Call : constant AASCIC :=
new ASCIC'(17, "Cond. entry call "); -- Call.Mode.Conditional_Call
Ada_State_Timed_Entry_Call : constant AASCIC :=
new ASCIC'(17, "Timed entry call "); -- Call.Mode.Timed_Call
Ada_State_Async_Entry_Call : constant AASCIC :=
new ASCIC'(17, "Async entry call "); -- Call.Mode.Asynchronous_Call (new)
-- Ada_State_Dependents_Exc : constant AASCIC :=
-- new ASCIC'(17, "Dependents [exc] ");
Ada_State_IO_or_AST : constant AASCIC :=
new ASCIC'(17, "I/O or AST "); -- AST_Server_Sleep
-- Ada_State_Shared_Resource : constant AASCIC :=
-- new ASCIC'(17, "Shared resource ");
Ada_State_Not_Yet_Activated : constant AASCIC :=
new ASCIC'(17, "Not yet activated"); -- Unactivated
-- Ada_State_Terminated_Abn : constant AASCIC :=
-- new ASCIC'(17, "Terminated [abn] ");
-- Ada_State_Terminated_Exc : constant AASCIC :=
-- new ASCIC'(17, "Terminated [exc] ");
Ada_State_Terminated : constant AASCIC :=
new ASCIC'(17, "Terminated "); -- Terminated
Ada_State_Server : constant AASCIC :=
new ASCIC'(17, "Server "); -- Servers
Ada_State_Async_Hold : constant AASCIC :=
new ASCIC'(17, "Async_Hold "); -- Async_Hold
-- Task state counted ascii constants
Debug_State_Emp : constant AASCIC := new ASCIC'(5, " ");
Debug_State_Run : constant AASCIC := new ASCIC'(5, "RUN ");
Debug_State_Rea : constant AASCIC := new ASCIC'(5, "READY");
Debug_State_Sus : constant AASCIC := new ASCIC'(5, "SUSP ");
Debug_State_Ter : constant AASCIC := new ASCIC'(5, "TERM ");
-- Priority order of event display
Global_Event_Display_Order : constant array (Event_Kind_Type)
of Event_Kind_Type := (
Debug_Event_Abort_Terminated,
Debug_Event_Activating,
Debug_Event_Dependents_Exception,
Debug_Event_Exception_Terminated,
Debug_Event_Handled,
Debug_Event_Handled_Others,
Debug_Event_Preempted,
Debug_Event_Rendezvous_Exception,
Debug_Event_Run,
Debug_Event_Suspended,
Debug_Event_Terminated);
-- Constant array defining all debug events
Event_Directory : constant array (Event_Kind_Type)
of Debug_Event_Record := (
(Debug_Event_Activating,
(False, False, False, False, False, False, False, True),
K_EVENT_SENT,
K_TS_TASK,
K_DTYPE_TASK,
0,
2,
(31, "ACTIVATING "),
new ASCIC'(41, "!_a task is about to begin its activation")),
(Debug_Event_Run,
(False, False, False, False, False, False, False, True),
K_EVENT_SENT,
K_TS_TASK,
K_DTYPE_TASK,
0,
2,
(31, "RUN "),
new ASCIC'(24, "!_a task is about to run")),
(Debug_Event_Suspended,
(False, False, False, False, False, False, False, True),
K_EVENT_SENT,
K_TS_TASK,
K_DTYPE_TASK,
0,
1,
(31, "SUSPENDED "),
new ASCIC'(33, "!_a task is about to be suspended")),
(Debug_Event_Preempted,
(False, False, False, False, False, False, False, True),
K_EVENT_SENT,
K_TS_TASK,
K_DTYPE_TASK,
0,
1,
(31, "PREEMPTED "),
new ASCIC'(33, "!_a task is about to be preempted")),
(Debug_Event_Terminated,
(False, False, False, False, False, False, False, True),
K_EVENT_SENT,
K_TS_TASK,
K_DTYPE_TASK,
0,
1,
(31, "TERMINATED "),
new ASCIC'(57,
"!_a task is terminating (including by abort or exception)")),
(Debug_Event_Abort_Terminated,
(False, False, False, False, False, False, False, True),
K_EVENT_SENT,
K_TS_TASK,
K_DTYPE_TASK,
0,
2,
(31, "ABORT_TERMINATED "),
new ASCIC'(40, "!_a task is terminating because of abort")),
(Debug_Event_Exception_Terminated,
(False, False, False, False, False, False, False, True),
K_EVENT_SENT,
K_TS_TASK,
K_DTYPE_TASK,
0,
1,
(31, "EXCEPTION_TERMINATED "),
new ASCIC'(47, "!_a task is terminating because of an exception")),
(Debug_Event_Rendezvous_Exception,
(False, False, False, False, False, False, False, True),
K_EVENT_SENT,
K_TS_TASK,
K_DTYPE_TASK,
0,
3,
(31, "RENDEZVOUS_EXCEPTION "),
new ASCIC'(49, "!_an exception is propagating out of a rendezvous")),
(Debug_Event_Handled,
(False, False, False, False, False, False, False, True),
K_EVENT_SENT,
K_TS_TASK,
K_DTYPE_TASK,
0,
1,
(31, "HANDLED "),
new ASCIC'(37, "!_an exception is about to be handled")),
(Debug_Event_Dependents_Exception,
(False, False, False, False, False, False, False, True),
K_EVENT_SENT,
K_TS_TASK,
K_DTYPE_TASK,
0,
1,
(31, "DEPENDENTS_EXCEPTION "),
new ASCIC'(64,
"!_an exception is about to cause a task to await dependent tasks")),
(Debug_Event_Handled_Others,
(False, False, False, False, False, False, False, True),
K_EVENT_SENT,
K_TS_TASK,
K_DTYPE_TASK,
0,
1,
(31, "HANDLED_OTHERS "),
new ASCIC'(58,
"!_an exception is about to be handled in an OTHERS handler")));
-- Help on events displayed in DEBUG
Event_Def_Help : constant AASCIC_Array := (
new ASCIC'(0, ""),
new ASCIC'(65,
" The general forms of commands to set a breakpoint or tracepoint"),
new ASCIC'(22, " on an Ada event are:"),
new ASCIC'(73, " SET BREAK/EVENT=event [task[, ... ]] " &
"[WHEN(expr)] [DO(comnd[; ... ])]"),
new ASCIC'(73, " SET TRACE/EVENT=event [task[, ... ]] " &
"[WHEN(expr)] [DO(comnd[; ... ])]"),
new ASCIC'(0, ""),
new ASCIC'(65,
" If tasks are specified, the breakpoint will trigger only if the"),
new ASCIC'(40, " event occurs for those specific tasks."),
new ASCIC'(0, ""),
new ASCIC'(39, " Ada event names and their definitions"),
new ASCIC'(0, ""));
-----------------------
-- Package Variables --
-----------------------
AC_Buffer : ASCIC127;
Events_Enabled_Count : Integer := 0;
Print_Routine_Bufsiz : constant := 132;
Print_Routine_Bufcnt : Integer := 0;
Print_Routine_Linbuf : String (1 .. Print_Routine_Bufsiz);
Global_Task_Debug_Events : Debug_Event_Array :=
(False, False, False, False, False, False, False, False,
False, False, False, False, False, False, False, False);
-- Global table of task debug events set by the debugger
--------------------------
-- Exported Subprograms --
--------------------------
procedure Default_Print_Routine
(Print_Function : Print_Functions;
Print_Subfunction : Print_Functions;
P1 : Unsigned_Longword := 0;
P2 : Unsigned_Longword := 0;
P3 : Unsigned_Longword := 0;
P4 : Unsigned_Longword := 0;
P5 : Unsigned_Longword := 0;
P6 : Unsigned_Longword := 0);
-- The default print routine if not overridden.
-- Print_Function determines option argument formatting.
-- Print_Subfunction buffers output if No_Print, calls Put_Output if
-- Print_Newline
pragma Export_Procedure
(Default_Print_Routine,
Mechanism => (Value, Value, Reference, Reference, Reference));
--------------------------
-- Imported Subprograms --
--------------------------
procedure Debug_Get
(Thread_Id : OSI.Thread_Id;
Item_Req : Unsigned_Word;
Out_Buff : System.Address;
Buff_Siz : Unsigned_Word);
procedure Debug_Get
(Thread_Id : OSI.Thread_Id;
Item_Req : Unsigned_Word;
Out_Buff : Unsigned_Longword;
Buff_Siz : Unsigned_Word);
pragma Interface (External, Debug_Get);
pragma Import_Procedure (Debug_Get, "CMA$DEBUG_GET",
(OSI.Thread_Id, Unsigned_Word, System.Address, Unsigned_Word),
(Reference, Value, Reference, Value));
pragma Import_Procedure (Debug_Get, "CMA$DEBUG_GET",
(OSI.Thread_Id, Unsigned_Word, Unsigned_Longword, Unsigned_Word),
(Reference, Value, Reference, Value));
procedure FAOL
(Status : out Cond_Value_Type;
Ctrstr : String;
Outlen : out Unsigned_Word;
Outbuf : out String;
Prmlst : Unsigned_Longword_Array);
pragma Interface (External, FAOL);
pragma Import_Valued_Procedure (FAOL, "SYS$FAOL",
(Cond_Value_Type, String, Unsigned_Word, String, Unsigned_Longword_Array),
(Value, Descriptor (S), Reference, Descriptor (S), Reference));
procedure Put_Output (
Status : out Cond_Value_Type;
Message_String : String);
procedure Put_Output (Message_String : String);
pragma Interface (External, Put_Output);
pragma Import_Valued_Procedure (Put_Output, "LIB$PUT_OUTPUT",
(Cond_Value_Type, String),
(Value, Short_Descriptor (S)));
pragma Import_Procedure (Put_Output, "LIB$PUT_OUTPUT",
(String),
(Short_Descriptor (S)));
procedure Signal
(Condition_Value : Cond_Value_Type;
Number_Of_Arguments : Integer := Integer'Null_Parameter;
FAO_Argument_1 : Unsigned_Longword :=
Unsigned_Longword'Null_Parameter);
pragma Interface (External, Signal);
pragma Import_Procedure (Signal, "LIB$SIGNAL",
(Cond_Value_Type, Integer, Unsigned_Longword),
(Value, Value, Value),
Number_Of_Arguments);
----------------------------
-- Generic Instantiations --
----------------------------
function Fetch is new Fetch_From_Address (Unsigned_Longword);
pragma Unreferenced (Fetch);
procedure Free is new Ada.Unchecked_Deallocation
(Object => Ada_Event_Control_Block_Type,
Name => Ada_Event_Control_Block_Access);
function To_AASCIC is new
Ada.Unchecked_Conversion (Unsigned_Longword, AASCIC);
function To_Addr is new
Ada.Unchecked_Conversion (Task_Procedure_Access, Address);
pragma Unreferenced (To_Addr);
function To_EVCB is new
Ada.Unchecked_Conversion
(Unsigned_Longword, Ada_Event_Control_Block_Access);
function To_Integer is new
Ada.Unchecked_Conversion (Task_Id, System.Task_Primitives.Task_Address);
function To_Print_Routine_Type is new
Ada.Unchecked_Conversion (Short_Address, Print_Routine_Type);
-- Optional argumements passed to Print_Routine have to be
-- Unsigned_Longwords so define the required Unchecked_Conversions
function To_UL is new
Ada.Unchecked_Conversion (AASCIC, Unsigned_Longword);
function To_UL is new
Ada.Unchecked_Conversion (Integer, Unsigned_Longword);
function To_UL is new
Ada.Unchecked_Conversion (Task_Id, Unsigned_Longword);
pragma Warnings (Off); -- Different sizes
function To_UL is new
Ada.Unchecked_Conversion (Task_Entry_Index, Unsigned_Longword);
pragma Warnings (On);
function To_UL is new
Ada.Unchecked_Conversion (Short_Address, Unsigned_Longword);
function To_UL is new
Ada.Unchecked_Conversion
(Ada_Event_Control_Block_Access, Unsigned_Longword);
-----------------------
-- Local Subprograms --
-----------------------
subtype Function_Codes is System.Aux_DEC.Unsigned_Word range 1 .. 31;
-- The 31 function codes sent by the debugger needed to implement
-- tasking support, enumerated below.
type Register_Array is array (Natural range 0 .. 16) of
System.Aux_DEC.Unsigned_Longword;
-- The register array is a holdover from VAX and not used
-- on Alpha or I64 but is kept as a filler below.
type DBGEXT_Control_Block (Function_Code : Function_Codes) is record
Facility_ID : System.Aux_DEC.Unsigned_Word;
-- For GNAT use the "Ada" facility ID
Status : System.Aux_DEC.Unsigned_Longword;
-- Successful or otherwise returned status
Flags : System.Aux_DEC.Bit_Array_32;
-- Used to flag event as global
Print_Routine : System.Aux_DEC.Short_Address;
-- The print subprogram the caller wants to use for output
Event_Code_or_EVCB : System.Aux_DEC.Unsigned_Longword;
-- Dual use Event Code or EVent Control Block
Event_Value_or_Name : System.Aux_DEC.Unsigned_Longword;
-- Dual use Event Value or Event Name string pointer
Event_Entry : System.Aux_DEC.Unsigned_Longword;
Task_Value : Task_Id;
Task_Number : Integer;
Ada_Flags : System.Aux_DEC.Bit_Array_32;
Priority : System.Aux_DEC.Bit_Array_32;
Active_Registers : System.Aux_DEC.Short_Address;
case Function_Code is
when K_GET_STATE_1 =>
Base_Priority : System.Aux_DEC.Bit_Array_32;
Task_Type_Name : System.Aux_DEC.Short_Address;
Creation_PC : System.Aux_DEC.Short_Address;
Parent_Task_ID : Task_Id;
when others =>
Ignored_Unused : Register_Array;
end case;
end record;
for DBGEXT_Control_Block use record
Function_Code at 0 range 0 .. 15;
Facility_ID at 2 range 0 .. 15;
Status at 4 range 0 .. 31;
Flags at 8 range 0 .. 31;
Print_Routine at 12 range 0 .. 31;
Event_Code_or_EVCB at 16 range 0 .. 31;
Event_Value_or_Name at 20 range 0 .. 31;
Event_Entry at 24 range 0 .. 31;
Task_Value at 28 range 0 .. 31;
Task_Number at 32 range 0 .. 31;
Ada_Flags at 36 range 0 .. 31;
Priority at 40 range 0 .. 31;
Active_Registers at 44 range 0 .. 31;
Ignored_Unused at 48 range 0 .. 17 * 32 - 1;
Base_Priority at 48 range 0 .. 31;
Task_Type_Name at 52 range 0 .. 31;
Creation_PC at 56 range 0 .. 31;
Parent_Task_ID at 60 range 0 .. 31;
end record;
type DBGEXT_Control_Block_Access is access all DBGEXT_Control_Block;
function DBGEXT (Control_Block : DBGEXT_Control_Block_Access)
return System.Aux_DEC.Unsigned_Word;
-- Exported to s-taprop.adb to avoid having a VMS specific s-tasdeb.ads
pragma Convention (C, DBGEXT);
pragma Export_Function (DBGEXT, "GNAT$DBGEXT");
-- This routine is called by CMA when VMS DEBUG wants the Gnat RTL
-- to give it some assistance (primarily when tasks are debugged).
--
-- The single parameter is an "external control block". On input to
-- the Gnat RTL this control block determines the debugging function
-- to be performed, and supplies parameters. This routine cases on
-- the function code, and calls the appropriate Gnat RTL routine,
-- which returns values by modifying the external control block.
procedure Announce_Event
(Event_EVCB : Unsigned_Longword;
Print_Routine : Print_Routine_Type := Default_Print_Routine'Access);
-- Announce the occurence of a DEBUG tasking event
procedure Cleanup_Event (Event_EVCB : Unsigned_Longword);
-- After DEBUG has processed an event that has signalled, the signaller
-- must cleanup. Cleanup consists of freeing the event control block.
procedure Disable_Event
(Flags : Bit_Array_32;
Event_Value : Unsigned_Longword;
Event_Code : Unsigned_Longword;
Status : out Cond_Value_Type);
-- Disable a DEBUG tasking event
function DoAC (S : String) return Address;
-- Convert a string to the address of an internal buffer containing
-- the counted ASCII.
procedure Enable_Event
(Flags : Bit_Array_32;
Event_Value : Unsigned_Longword;
Event_Code : Unsigned_Longword;
Status : out Cond_Value_Type);
-- Enable a requested DEBUG tasking event
procedure Find_Event_By_Code
(Event_Code : Unsigned_Longword;
Event_Entry : out Unsigned_Longword;
Status : out Cond_Value_Type);
-- Convert an event code to the address of the event entry
procedure Find_Event_By_Name
(Event_Name : Unsigned_Longword;
Event_Entry : out Unsigned_Longword;
Status : out Cond_Value_Type);
-- Find an event entry given the event name
procedure List_Entry_Waiters
(Task_Value : Task_Id;
Full_Display : Boolean := False;
Suppress_Header : Boolean := False;
Print_Routine : Print_Routine_Type := Default_Print_Routine'Access);
-- List information about tasks waiting on an entry
procedure Put (S : String);
-- Display S on standard output
procedure Put_Line (S : String := "");
-- Display S on standard output with an additional line terminator
procedure Show_Event
(Print_Routine : Print_Routine_Type := Default_Print_Routine'Access);
-- Show what events are available
procedure Show_One_Task
(Task_Value : Task_Id;
Full_Display : Boolean := False;
Suppress_Header : Boolean := False;
Print_Routine : Print_Routine_Type := Default_Print_Routine'Access);
-- Display information about one task
procedure Show_Rendezvous
(Task_Value : Task_Id;
Ada_State : AASCIC := Empty_Text;
Full_Display : Boolean := False;
Suppress_Header : Boolean := False;
Print_Routine : Print_Routine_Type := Default_Print_Routine'Access);
-- Display information about a task rendezvous
procedure Trace_Output (Message_String : String);
-- Call Put_Output if Trace_on ("VMS")
procedure Write (Fd : Integer; S : String; Count : Integer);
--------------------
-- Announce_Event --
--------------------
procedure Announce_Event
(Event_EVCB : Unsigned_Longword;
Print_Routine : Print_Routine_Type := Default_Print_Routine'Access)
is
EVCB : constant Ada_Event_Control_Block_Access := To_EVCB (Event_EVCB);
Event_Kind : constant Event_Kind_Type :=
(if EVCB.Sub_Event /= 0
then Event_Kind_Type (EVCB.Sub_Event)
else Event_Kind_Type (EVCB.Code));
TI : constant String := " Task %TASK !UI is ";
-- Announce prefix
begin
Trace_Output ("Announce called");
case Event_Kind is
when Debug_Event_Activating =>
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (TI & "about to begin its activation")),
EVCB.Value);
when Debug_Event_Exception_Terminated =>
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (TI & "terminating because of an exception")),
EVCB.Value);
when Debug_Event_Run =>
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (TI & "about to run")),
EVCB.Value);
when Debug_Event_Abort_Terminated =>
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (TI & "terminating because of abort")),
EVCB.Value);
when Debug_Event_Terminated =>
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (TI & "terminating normally")),
EVCB.Value);
when others => null;
end case;
end Announce_Event;
-------------------
-- Cleanup_Event --
-------------------
procedure Cleanup_Event (Event_EVCB : Unsigned_Longword) is
EVCB : Ada_Event_Control_Block_Access := To_EVCB (Event_EVCB);
begin
Free (EVCB);
end Cleanup_Event;
------------------------
-- Continue_All_Tasks --
------------------------
procedure Continue_All_Tasks is
begin
null; -- VxWorks
end Continue_All_Tasks;
------------
-- DBGEXT --
------------
function DBGEXT
(Control_Block : DBGEXT_Control_Block_Access)
return System.Aux_DEC.Unsigned_Word
is
Print_Routine : Print_Routine_Type := Default_Print_Routine'Access;
begin
Trace_Output ("DBGEXT called");
if Control_Block.Print_Routine /= Address_Zero then
Print_Routine := To_Print_Routine_Type (Control_Block.Print_Routine);
end if;
case Control_Block.Function_Code is
-- Convert a task value to a task number.
-- The output results are stored in the CONTROL_BLOCK.
when K_CVT_VALUE_NUM =>
Trace_Output ("DBGEXT param 1 - CVT Value to NUM");
Control_Block.Task_Number :=
Control_Block.Task_Value.Known_Tasks_Index + 1;
Control_Block.Status := K_SUCCESS;
Trace_Output ("Task Number: ");
Trace_Output (Integer'Image (Control_Block.Task_Number));
return SS_NORMAL;
-- Convert a task number to a task value.
-- The output results are stored in the CONTROL_BLOCK.
when K_CVT_NUM_VALUE =>
Trace_Output ("DBGEXT param 2 - CVT NUM to Value");
Trace_Output ("Task Number: ");
Trace_Output (Integer'Image (Control_Block.Task_Number));
Control_Block.Task_Value :=
Known_Tasks (Control_Block.Task_Number - 1);
Control_Block.Status := K_SUCCESS;
Trace_Output ("Task Value: ");
Trace_Output (Unsigned_Longword'Image
(To_UL (Control_Block.Task_Value)));
return SS_NORMAL;
-- Obtain the "next" task after a specified task.
-- ??? To do: If specified check the PRIORITY, STATE, and HOLD
-- fields to restrict the selection of the next task.
-- The output results are stored in the CONTROL_BLOCK.
when K_NEXT_TASK =>
Trace_Output ("DBGEXT param 3 - Next Task");
Trace_Output ("Task Value: ");
Trace_Output (Unsigned_Longword'Image
(To_UL (Control_Block.Task_Value)));
if Control_Block.Task_Value = null then
Control_Block.Task_Value := Known_Tasks (Known_Tasks'First);
else
Control_Block.Task_Value :=
Known_Tasks (Control_Block.Task_Value.Known_Tasks_Index + 1);
end if;
if Control_Block.Task_Value = null then
Control_Block.Task_Value := Known_Tasks (Known_Tasks'First);
end if;
Control_Block.Status := K_SUCCESS;
return SS_NORMAL;
-- Display the state of a task. The FULL bit is checked to decide if
-- a full or brief task display is desired. The output results are
-- stored in the CONTROL_BLOCK.
when K_SHOW_TASK =>
Trace_Output ("DBGEXT param 4 - Show Task");
if Control_Block.Task_Value = null then
Control_Block.Status := K_TASK_NOT_EXIST;
else
Show_One_Task
(Control_Block.Task_Value,
Control_Block.Ada_Flags (V_Full_Display),
Control_Block.Ada_Flags (V_Suppress_Header),
Print_Routine);
Control_Block.Status := K_SUCCESS;
end if;
return SS_NORMAL;
-- Enable a requested DEBUG tasking event
when K_ENABLE_EVENT =>
Trace_Output ("DBGEXT param 17 - Enable Event");
Enable_Event
(Control_Block.Flags,
Control_Block.Event_Value_or_Name,
Control_Block.Event_Code_or_EVCB,
Control_Block.Status);
return SS_NORMAL;
-- Disable a DEBUG tasking event
when K_DISABLE_EVENT =>
Trace_Output ("DBGEXT param 18 - Disable Event");
Disable_Event
(Control_Block.Flags,
Control_Block.Event_Value_or_Name,
Control_Block.Event_Code_or_EVCB,
Control_Block.Status);
return SS_NORMAL;
-- Announce the occurence of a DEBUG tasking event
when K_ANNOUNCE_EVENT =>
Trace_Output ("DBGEXT param 19 - Announce Event");
Announce_Event
(Control_Block.Event_Code_or_EVCB,
Print_Routine);
Control_Block.Status := K_SUCCESS;
return SS_NORMAL;
-- After DEBUG has processed an event that has signalled,
-- the signaller must cleanup.
-- Cleanup consists of freeing the event control block.
when K_CLEANUP_EVENT =>
Trace_Output ("DBGEXT param 24 - Cleanup Event");
Cleanup_Event (Control_Block.Event_Code_or_EVCB);
Control_Block.Status := K_SUCCESS;
return SS_NORMAL;
-- Show what events are available
when K_SHOW_EVENT_DEF =>
Trace_Output ("DBGEXT param 25 - Show Event Def");
Show_Event (Print_Routine);
Control_Block.Status := K_SUCCESS;
return SS_NORMAL;
-- Convert an event code to the address of the event entry
when K_FIND_EVENT_BY_CODE =>
Trace_Output ("DBGEXT param 29 - Find Event by Code");
Find_Event_By_Code
(Control_Block.Event_Code_or_EVCB,
Control_Block.Event_Entry,
Control_Block.Status);
return SS_NORMAL;
-- Find an event entry given the event name
when K_FIND_EVENT_BY_NAME =>
Trace_Output ("DBGEXT param 30 - Find Event by Name");
Find_Event_By_Name
(Control_Block.Event_Value_or_Name,
Control_Block.Event_Entry,
Control_Block.Status);
return SS_NORMAL;
-- ??? To do: Implement priority events
-- Get, set or restore a task's priority
when K_GET_PRIORITY or K_SET_PRIORITY or K_RESTORE_PRIORITY =>
Trace_Output ("DBGEXT priority param - Not yet implemented");
Trace_Output (Function_Codes'Image
(Control_Block.Function_Code));
return SS_BADPARAM;
-- ??? To do: Implement show statistics event
-- Display task statistics
when K_SHOW_STAT =>
Trace_Output ("DBGEXT show stat param - Not yet implemented");
Trace_Output (Function_Codes'Image
(Control_Block.Function_Code));
return SS_BADPARAM;
-- ??? To do: Implement get caller event
-- Obtain the caller of a task in a rendezvous. If no rendezvous,
-- null is returned
when K_GET_CALLER =>
Trace_Output ("DBGEXT get caller param - Not yet implemented");
Trace_Output (Function_Codes'Image
(Control_Block.Function_Code));
return SS_BADPARAM;
-- ??? To do: Implement set terminate event
-- Terminate a task
when K_SET_ABORT =>
Trace_Output ("DBGEXT set terminate param - Not yet implemented");
Trace_Output (Function_Codes'Image
(Control_Block.Function_Code));
return SS_BADPARAM;
-- ??? To do: Implement show deadlock event
-- Detect a deadlock
when K_SHOW_DEADLOCK =>
Trace_Output ("DBGEXT show deadlock param - Not yet implemented");
Trace_Output (Function_Codes'Image
(Control_Block.Function_Code));
return SS_BADPARAM;
when others =>
Trace_Output ("DBGEXT bad param: ");
Trace_Output (Function_Codes'Image
(Control_Block.Function_Code));
return SS_BADPARAM;
end case;
end DBGEXT;
---------------------------
-- Default_Print_Routine --
---------------------------
procedure Default_Print_Routine
(Print_Function : Print_Functions;
Print_Subfunction : Print_Functions;
P1 : Unsigned_Longword := 0;
P2 : Unsigned_Longword := 0;
P3 : Unsigned_Longword := 0;
P4 : Unsigned_Longword := 0;
P5 : Unsigned_Longword := 0;
P6 : Unsigned_Longword := 0)
is
Status : Cond_Value_Type;
Linlen : Unsigned_Word;
Item_List : Unsigned_Longword_Array (1 .. 17) :=
(1 .. 17 => 0);
begin
case Print_Function is
when Print_Control | Print_String =>
null;
-- Formatted Ascii Output
when Print_FAO =>
Item_List (1) := P2;
Item_List (2) := P3;
Item_List (3) := P4;
Item_List (4) := P5;
Item_List (5) := P6;
FAOL
(Status,
To_AASCIC (P1).Text,
Linlen,
Print_Routine_Linbuf
(1 + Print_Routine_Bufcnt .. Print_Routine_Bufsiz),
Item_List);
Print_Routine_Bufcnt := Print_Routine_Bufcnt + Integer (Linlen);
-- Symbolic output
when Print_Symbol =>
Item_List (1) := P1;
FAOL
(Status,
"!XI",
Linlen,
Print_Routine_Linbuf
(1 + Print_Routine_Bufcnt .. Print_Routine_Bufsiz),
Item_List);
Print_Routine_Bufcnt := Print_Routine_Bufcnt + Integer (Linlen);
when others =>
null;
end case;
case Print_Subfunction is
-- Output buffer with a terminating newline
when Print_Newline =>
Put_Output (Status,
Print_Routine_Linbuf (1 .. Print_Routine_Bufcnt));
Print_Routine_Bufcnt := 0;
-- Buffer the output
when No_Print =>
null;
when others =>
null;
end case;
end Default_Print_Routine;
-------------------
-- Disable_Event --
-------------------
procedure Disable_Event
(Flags : Bit_Array_32;
Event_Value : Unsigned_Longword;
Event_Code : Unsigned_Longword;
Status : out Cond_Value_Type)
is
Task_Value : Task_Id;
Task_Index : constant Integer := Integer (Event_Value) - 1;
begin
Events_Enabled_Count := Events_Enabled_Count - 1;
if Flags (V_EVNT_ALL) then
Global_Task_Debug_Events (Integer (Event_Code)) := False;
Status := K_SUCCESS;
else
if Task_Index in Known_Tasks'Range then
Task_Value := Known_Tasks (Task_Index);
if Task_Value /= null then
Task_Value.Common.Debug_Events (Integer (Event_Code)) := False;
Status := K_SUCCESS;
else
Status := K_TASK_NOT_EXIST;
end if;
else
Status := K_TASK_NOT_EXIST;
end if;
end if;
-- Keep count of events for efficiency
if Events_Enabled_Count <= 0 then
Events_Enabled_Count := 0;
Global_Task_Debug_Event_Set := False;
end if;
end Disable_Event;
----------
-- DoAC --
----------
function DoAC (S : String) return Address is
begin
AC_Buffer.Count := S'Length;
AC_Buffer.Text (1 .. AC_Buffer.Count) := S;
return AC_Buffer'Address;
end DoAC;
------------------
-- Enable_Event --
------------------
procedure Enable_Event
(Flags : Bit_Array_32;
Event_Value : Unsigned_Longword;
Event_Code : Unsigned_Longword;
Status : out Cond_Value_Type)
is
Task_Value : Task_Id;
Task_Index : constant Integer := Integer (Event_Value) - 1;
begin
-- At least one event enabled, any and all events will cause a
-- condition to be raised and checked. Major tasking slowdown!
Global_Task_Debug_Event_Set := True;
Events_Enabled_Count := Events_Enabled_Count + 1;
if Flags (V_EVNT_ALL) then
Global_Task_Debug_Events (Integer (Event_Code)) := True;
Status := K_SUCCESS;
else
if Task_Index in Known_Tasks'Range then
Task_Value := Known_Tasks (Task_Index);
if Task_Value /= null then
Task_Value.Common.Debug_Events (Integer (Event_Code)) := True;
Status := K_SUCCESS;
else
Status := K_TASK_NOT_EXIST;
end if;
else
Status := K_TASK_NOT_EXIST;
end if;
end if;
end Enable_Event;
------------------------
-- Find_Event_By_Code --
------------------------
procedure Find_Event_By_Code
(Event_Code : Unsigned_Longword;
Event_Entry : out Unsigned_Longword;
Status : out Cond_Value_Type)
is
K_SUCCESS : constant := 1;
K_NO_SUCH_EVENT : constant := 9;
begin
Trace_Output ("Looking for Event: ");
Trace_Output (Unsigned_Longword'Image (Event_Code));
for I in Event_Kind_Type'Range loop
if Event_Code = Unsigned_Longword (Event_Directory (I).Code) then
Event_Entry := To_UL (Event_Directory (I)'Address);
Trace_Output ("Found Event # ");
Trace_Output (Integer'Image (I));
Status := K_SUCCESS;
return;
end if;
end loop;
Status := K_NO_SUCH_EVENT;
end Find_Event_By_Code;
------------------------
-- Find_Event_By_Name --
------------------------
procedure Find_Event_By_Name
(Event_Name : Unsigned_Longword;
Event_Entry : out Unsigned_Longword;
Status : out Cond_Value_Type)
is
K_SUCCESS : constant := 1;
K_NO_SUCH_EVENT : constant := 9;
Event_Name_Cstr : constant ASCIC := To_AASCIC (Event_Name).all;
begin
Trace_Output ("Looking for Event: ");
Trace_Output (Event_Name_Cstr.Text);
for I in Event_Kind_Type'Range loop
if Event_Name_Cstr.Count >= Event_Directory (I).Minchr
and then Event_Name_Cstr.Count <= Event_Directory (I).Name.Count
and then Event_Name_Cstr.Text (1 .. Event_Directory (I).Minchr) =
Event_Directory (I).Name.Text (1 .. Event_Directory (I).Minchr)
then
Event_Entry := To_UL (Event_Directory (I)'Address);
Trace_Output ("Found Event # ");
Trace_Output (Integer'Image (I));
Status := K_SUCCESS;
return;
end if;
end loop;
Status := K_NO_SUCH_EVENT;
end Find_Event_By_Name;
--------------------
-- Get_User_State --
--------------------
function Get_User_State return Long_Integer is
begin
return STPO.Self.User_State;
end Get_User_State;
------------------------
-- List_Entry_Waiters --
------------------------
procedure List_Entry_Waiters
(Task_Value : Task_Id;
Full_Display : Boolean := False;
Suppress_Header : Boolean := False;
Print_Routine : Print_Routine_Type := Default_Print_Routine'Access)
is
pragma Unreferenced (Suppress_Header);
Entry_Call : Entry_Call_Link;
Have_Some : Boolean := False;
begin
if not Full_Display then
return;
end if;
if Task_Value.Entry_Queues'Length > 0 then
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (" Waiting entry callers:")));
end if;
for I in Task_Value.Entry_Queues'Range loop
Entry_Call := Task_Value.Entry_Queues (I).Head;
if Entry_Call /= null then
Have_Some := True;
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (" Waiters for entry !UI:")),
To_UL (I));
loop
declare
Task_Image : ASCIC :=
(Entry_Call.Self.Common.Task_Image_Len,
Entry_Call.Self.Common.Task_Image
(1 .. Entry_Call.Self.Common.Task_Image_Len));
begin
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (" %TASK !UI, type: !AC")),
To_UL (Entry_Call.Self.Known_Tasks_Index + 1),
To_UL (Task_Image'Address));
if Entry_Call = Task_Value.Entry_Queues (I).Tail then
exit;
end if;
Entry_Call := Entry_Call.Next;
end;
end loop;
end if;
end loop;
if not Have_Some then
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (" none.")));
end if;
end List_Entry_Waiters;
----------------
-- List_Tasks --
----------------
procedure List_Tasks is
C : Task_Id;
begin
C := All_Tasks_List;
while C /= null loop
Print_Task_Info (C);
C := C.Common.All_Tasks_Link;
end loop;
end List_Tasks;
------------------------
-- Print_Current_Task --
------------------------
procedure Print_Current_Task is
begin
Print_Task_Info (STPO.Self);
end Print_Current_Task;
---------------------
-- Print_Task_Info --
---------------------
procedure Print_Task_Info (T : Task_Id) is
Entry_Call : Entry_Call_Link;
Parent : Task_Id;
begin
if T = null then
Put_Line ("null task");
return;
end if;
Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len) & ": " &
Task_States'Image (T.Common.State));
Parent := T.Common.Parent;
if Parent = null then
Put (", parent: <none>");
else
Put (", parent: " &
Parent.Common.Task_Image (1 .. Parent.Common.Task_Image_Len));
end if;
Put (", prio:" & T.Common.Current_Priority'Img);
if not T.Callable then
Put (", not callable");
end if;
if T.Aborting then
Put (", aborting");
end if;
if T.Deferral_Level /= 0 then
Put (", abort deferred");
end if;
if T.Common.Call /= null then
Entry_Call := T.Common.Call;
Put (", serving:");
while Entry_Call /= null loop
Put (To_Integer (Entry_Call.Self)'Img);
Entry_Call := Entry_Call.Acceptor_Prev_Call;
end loop;
end if;
if T.Open_Accepts /= null then
Put (", accepting:");
for J in T.Open_Accepts'Range loop
Put (T.Open_Accepts (J).S'Img);
end loop;
if T.Terminate_Alternative then
Put (" or terminate");
end if;
end if;
if T.User_State /= 0 then
Put (", state:" & T.User_State'Img);
end if;
Put_Line;
end Print_Task_Info;
---------
-- Put --
---------
procedure Put (S : String) is
begin
Write (2, S, S'Length);
end Put;
--------------
-- Put_Line --
--------------
procedure Put_Line (S : String := "") is
begin
Write (2, S & ASCII.LF, S'Length + 1);
end Put_Line;
----------------------
-- Resume_All_Tasks --
----------------------
procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
pragma Unreferenced (Thread_Self);
begin
null; -- VxWorks
end Resume_All_Tasks;
---------------
-- Set_Trace --
---------------
procedure Set_Trace (Flag : Character; Value : Boolean := True) is
begin
Trace_On (Flag) := Value;
end Set_Trace;
--------------------
-- Set_User_State --
--------------------
procedure Set_User_State (Value : Long_Integer) is
begin
STPO.Self.User_State := Value;
end Set_User_State;
----------------
-- Show_Event --
----------------
procedure Show_Event
(Print_Routine : Print_Routine_Type := Default_Print_Routine'Access)
is
begin
for I in Event_Def_Help'Range loop
Print_Routine (Print_FAO, Print_Newline, To_UL (Event_Def_Help (I)));
end loop;
for I in Event_Kind_Type'Range loop
Print_Routine (Print_FAO, Print_Newline,
To_UL (Event_Directory
(Global_Event_Display_Order (I)).Name'Address));
Print_Routine (Print_FAO, Print_Newline,
To_UL (Event_Directory (Global_Event_Display_Order (I)).Help));
end loop;
end Show_Event;
--------------------
-- Show_One_Task --
--------------------
procedure Show_One_Task
(Task_Value : Task_Id;
Full_Display : Boolean := False;
Suppress_Header : Boolean := False;
Print_Routine : Print_Routine_Type := Default_Print_Routine'Access)
is
Task_SP : System.Address := Address_Zero;
Stack_Base : System.Address := Address_Zero;
Stack_Top : System.Address := Address_Zero;
TCB_Size : Unsigned_Longword := 0;
CMA_TCB_Size : Unsigned_Longword := 0;
Stack_Guard_Size : Unsigned_Longword := 0;
Total_Task_Storage : Unsigned_Longword := 0;
Stack_In_Use : Unsigned_Longword := 0;
Reserved_Size : Unsigned_Longword := 0;
Hold_Flag : Unsigned_Longword := 0;
Sched_State : Unsigned_Longword := 0;
User_Prio : Unsigned_Longword := 0;
Stack_Size : Unsigned_Longword := 0;
Run_State : Boolean := False;
Rea_State : Boolean := False;
Sus_State : Boolean := False;
Ter_State : Boolean := False;
Current_Flag : AASCIC := NoStar;
Hold_String : AASCIC := NoHold;
Ada_State : AASCIC := Ada_State_Invalid_State;
Debug_State : AASCIC := Debug_State_Emp;
Ada_State_Len : constant Unsigned_Longword := 17;
Debug_State_Len : constant Unsigned_Longword := 5;
Entry_Call : Entry_Call_Record;
begin
-- Initialize local task info variables
Task_SP := Address_Zero;
Stack_Base := Address_Zero;
Stack_Top := Address_Zero;
CMA_TCB_Size := 0;
Stack_Guard_Size := 0;
Reserved_Size := 0;
Hold_Flag := 0;
Sched_State := 0;
TCB_Size := Unsigned_Longword (Task_Id'Size);
if not Suppress_Header or else Full_Display then
Print_Routine (Print_FAO, Print_Newline, To_UL (Empty_Text));
Print_Routine (Print_FAO, Print_Newline, To_UL (Header));
end if;
Trace_Output ("Show_One_Task Task Value: ");
Trace_Output (Unsigned_Longword'Image (To_UL (Task_Value)));
-- Callback to DEBUG to get some task info
if Task_Value.Common.State /= Terminated then
Debug_Get
(STPO.Get_Thread_Id (Task_Value),
CMA_C_DEBGET_STACKPTR,
Task_SP,
8);
Debug_Get
(STPO.Get_Thread_Id (Task_Value),
CMA_C_DEBGET_TCB_SIZE,
CMA_TCB_Size,
4);
Debug_Get
(STPO.Get_Thread_Id (Task_Value),
CMA_C_DEBGET_GUARDSIZE,
Stack_Guard_Size,
4);
Debug_Get
(STPO.Get_Thread_Id (Task_Value),
CMA_C_DEBGET_YELLOWSIZE,
Reserved_Size,
4);
Debug_Get
(STPO.Get_Thread_Id (Task_Value),
CMA_C_DEBGET_STACK_BASE,
Stack_Base,
8);
Debug_Get
(STPO.Get_Thread_Id (Task_Value),
CMA_C_DEBGET_STACK_TOP,
Stack_Top,
8);
Stack_Size := Unsigned_Longword (Stack_Base - Stack_Top)
- Reserved_Size - Stack_Guard_Size;
Stack_In_Use := Unsigned_Longword (Stack_Base - Task_SP) + 4;
Total_Task_Storage := TCB_Size + Stack_Size + Stack_Guard_Size
+ Reserved_Size + CMA_TCB_Size;
Debug_Get
(STPO.Get_Thread_Id (Task_Value),
CMA_C_DEBGET_IS_HELD,
Hold_Flag,
4);
Hold_String := (if Hold_Flag /= 0 then Hold else NoHold);
Debug_Get
(STPO.Get_Thread_Id (Task_Value),
CMA_C_DEBGET_SCHED_STATE,
Sched_State,
4);
end if;
Run_State := False;
Rea_State := False;
Sus_State := Task_Value.Common.State = Unactivated;
Ter_State := Task_Value.Common.State = Terminated;
if not Ter_State then
Run_State := Sched_State = 0;
Rea_State := Sched_State = 1;
Sus_State := Sched_State /= 0 and Sched_State /= 1;
end if;
-- Set the debug state
if Run_State then
Debug_State := Debug_State_Run;
elsif Rea_State then
Debug_State := Debug_State_Rea;
elsif Sus_State then
Debug_State := Debug_State_Sus;
elsif Ter_State then
Debug_State := Debug_State_Ter;
end if;
Trace_Output ("Before case State: ");
Trace_Output (Task_States'Image (Task_Value.Common.State));
-- Set the Ada state
case Task_Value.Common.State is
when Unactivated =>
Ada_State := Ada_State_Not_Yet_Activated;
when Activating =>
Ada_State := Ada_State_Activating;
when Runnable =>
Ada_State := Ada_State_Runnable;
when Terminated =>
Ada_State := Ada_State_Terminated;
when Activator_Sleep =>
Ada_State := Ada_State_Activating_Tasks;
when Acceptor_Sleep =>
Ada_State := Ada_State_Accept;
when Acceptor_Delay_Sleep =>
Ada_State := Ada_State_Select_or_Delay;
when Entry_Caller_Sleep =>
Entry_Call :=
Task_Value.Entry_Calls (Task_Value.ATC_Nesting_Level);
case Entry_Call.Mode is
when Simple_Call =>
Ada_State := Ada_State_Entry_Call;
when Conditional_Call =>
Ada_State := Ada_State_Cond_Entry_Call;
when Timed_Call =>
Ada_State := Ada_State_Timed_Entry_Call;
when Asynchronous_Call =>
Ada_State := Ada_State_Async_Entry_Call;
end case;
when Async_Select_Sleep =>
Ada_State := Ada_State_Select_or_Abort;
when Delay_Sleep =>
Ada_State := Ada_State_Delay;
when Master_Completion_Sleep =>
Ada_State := Ada_State_Completed;
when Master_Phase_2_Sleep =>
Ada_State := Ada_State_Completed;
when Interrupt_Server_Idle_Sleep |
Interrupt_Server_Blocked_Interrupt_Sleep |
Timer_Server_Sleep |
Interrupt_Server_Blocked_On_Event_Flag =>
Ada_State := Ada_State_Server;
when AST_Server_Sleep =>
Ada_State := Ada_State_IO_or_AST;
when Asynchronous_Hold =>
Ada_State := Ada_State_Async_Hold;
end case;
if Task_Value.Terminate_Alternative then
Ada_State := Ada_State_Select_or_Term;
end if;
if Task_Value.Aborting then
Ada_State := Ada_State_Aborting;
end if;
User_Prio := To_UL (Task_Value.Common.Current_Priority);
Trace_Output ("After user_prio");
-- Flag the current task
Current_Flag := (if Task_Value = Self then Star else NoStar);
-- Show task info
Print_Routine (Print_FAO, No_Print, To_UL (DoAC ("!AC%TASK !5<!UI!>")),
To_UL (Current_Flag), To_UL (Task_Value.Known_Tasks_Index + 1));
Print_Routine (Print_FAO, No_Print, To_UL (DoAC ("!2UB")), User_Prio);
Print_Routine (Print_FAO, No_Print, To_UL (DoAC (" !AC !5AD !17AD ")),
To_UL (Hold_String), Debug_State_Len, To_UL (Debug_State),
Ada_State_Len, To_UL (Ada_State));
-- Print_Routine (Print_Symbol, Print_Newline,
-- Fetch (To_Addr (Task_Value.Common.Task_Entry_Point)));
Print_Routine (Print_FAO, Print_Newline, To_UL (Empty_Text));
-- If /full qualfier passed, show detailed info
if Full_Display then
Show_Rendezvous (Task_Value, Ada_State, Full_Display,
Suppress_Header, Print_Routine);
List_Entry_Waiters (Task_Value, Full_Display,
Suppress_Header, Print_Routine);
Print_Routine (Print_FAO, Print_Newline, To_UL (Empty_Text));
declare
Task_Image : ASCIC := (Task_Value.Common.Task_Image_Len,
Task_Value.Common.Task_Image
(1 .. Task_Value.Common.Task_Image_Len));
begin
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (" Task type: !AC")),
To_UL (Task_Image'Address));
end;
-- How to find Creation_PC ???
-- Print_Routine (Print_FAO, No_Print,
-- To_UL (DoAC (" Created at PC: ")),
-- Print_Routine (Print_FAO, Print_Newline, Creation_PC);
if Task_Value.Common.Parent /= null then
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (" Parent task: %TASK !UI")),
To_UL (Task_Value.Common.Parent.Known_Tasks_Index + 1));
else
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (" Parent task: none")));
end if;
-- Print_Routine (Print_FAO, No_Print,
-- To_UL (DoAC (" Start PC: ")));
-- Print_Routine (Print_Symbol, Print_Newline,
-- Fetch (To_Addr (Task_Value.Common.Task_Entry_Point)));
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (
" Task control block: Stack storage (bytes):")));
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (
" Task value: !10<!UI!> RESERVED_BYTES: !10UI")),
To_UL (Task_Value), Reserved_Size);
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (
" Entries: !10<!UI!> TOP_GUARD_SIZE: !10UI")),
To_UL (Task_Value.Entry_Num), Stack_Guard_Size);
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (
" Size: !10<!UI!> STORAGE_SIZE: !10UI")),
TCB_Size + CMA_TCB_Size, Stack_Size);
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (
" Stack addresses: Bytes in use: !10UI")),
Stack_In_Use);
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (" Top address: !10<!XI!>")),
To_UL (Stack_Top));
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (
" Base address: !10<!XI!> Total storage: !10UI")),
To_UL (Stack_Base), Total_Task_Storage);
end if;
end Show_One_Task;
---------------------
-- Show_Rendezvous --
---------------------
procedure Show_Rendezvous
(Task_Value : Task_Id;
Ada_State : AASCIC := Empty_Text;
Full_Display : Boolean := False;
Suppress_Header : Boolean := False;
Print_Routine : Print_Routine_Type := Default_Print_Routine'Access)
is
pragma Unreferenced (Ada_State);
pragma Unreferenced (Suppress_Header);
Temp_Entry : Entry_Index;
Entry_Call : Entry_Call_Record;
Called_Task : Task_Id;
AWR : constant String := " Awaiting rendezvous at: ";
-- Common prefix
procedure Print_Accepts;
-- Display information about task rendezvous accepts
procedure Print_Accepts is
begin
if Task_Value.Open_Accepts /= null then
for I in Task_Value.Open_Accepts'Range loop
Temp_Entry := Entry_Index (Task_Value.Open_Accepts (I).S);
declare
Entry_Name_Image : ASCIC :=
(Task_Value.Entry_Names (Temp_Entry).all'Length,
Task_Value.Entry_Names (Temp_Entry).all);
begin
Trace_Output ("Accept at: " & Entry_Name_Image.Text);
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (" accept at: !AC")),
To_UL (Entry_Name_Image'Address));
end;
end loop;
end if;
end Print_Accepts;
begin
if not Full_Display then
return;
end if;
Trace_Output ("Show_Rendezvous Task Value: ");
Trace_Output (Unsigned_Longword'Image (To_UL (Task_Value)));
if Task_Value.Common.State = Acceptor_Sleep and then
not Task_Value.Terminate_Alternative
then
if Task_Value.Open_Accepts /= null then
Temp_Entry := Entry_Index (Task_Value.Open_Accepts
(Task_Value.Open_Accepts'First).S);
declare
Entry_Name_Image : ASCIC :=
(Task_Value.Entry_Names (Temp_Entry).all'Length,
Task_Value.Entry_Names (Temp_Entry).all);
begin
Trace_Output (AWR & "accept " & Entry_Name_Image.Text);
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (AWR & "accept !AC")),
To_UL (Entry_Name_Image'Address));
end;
else
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (" entry name unavailable")));
end if;
else
case Task_Value.Common.State is
when Acceptor_Sleep =>
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (AWR & "select with terminate.")));
Print_Accepts;
when Async_Select_Sleep =>
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (AWR & "select.")));
Print_Accepts;
when Acceptor_Delay_Sleep =>
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (AWR & "select with delay.")));
Print_Accepts;
when Entry_Caller_Sleep =>
Entry_Call :=
Task_Value.Entry_Calls (Task_Value.ATC_Nesting_Level);
case Entry_Call.Mode is
when Simple_Call =>
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (AWR & "entry call")));
when Conditional_Call =>
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (AWR & "entry call with else")));
when Timed_Call =>
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (AWR & "entry call with delay")));
when Asynchronous_Call =>
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC (AWR & "entry call with abort")));
end case;
Called_Task := Entry_Call.Called_Task;
declare
Task_Image : ASCIC := (Called_Task.Common.Task_Image_Len,
Called_Task.Common.Task_Image
(1 .. Called_Task.Common.Task_Image_Len));
Entry_Name_Image : ASCIC :=
(Called_Task.Entry_Names (Entry_Call.E).all'Length,
Called_Task.Entry_Names (Entry_Call.E).all);
begin
Print_Routine (Print_FAO, Print_Newline,
To_UL (DoAC
(" for entry !AC in %TASK !UI type !AC")),
To_UL (Entry_Name_Image'Address),
To_UL (Called_Task.Known_Tasks_Index),
To_UL (Task_Image'Address));
end;
when others =>
return;
end case;
end if;
end Show_Rendezvous;
------------------------
-- Signal_Debug_Event --
------------------------
procedure Signal_Debug_Event
(Event_Kind : Event_Kind_Type; Task_Value : Task_Id)
is
Do_Signal : Boolean;
EVCB : Ada_Event_Control_Block_Access;
EVCB_Sent : constant := 16#9B#;
Ada_Facility : constant := 49;
SS_DBGEVENT : constant := 1729;
begin
Do_Signal := Global_Task_Debug_Events (Event_Kind);
if not Do_Signal then
if Task_Value /= null then
Do_Signal := Do_Signal
or else Task_Value.Common.Debug_Events (Event_Kind);
end if;
end if;
if Do_Signal then
-- Build an a tasking event control block and signal DEBUG
EVCB := new Ada_Event_Control_Block_Type;
EVCB.Code := Unsigned_Word (Event_Kind);
EVCB.Sentinal := EVCB_Sent;
EVCB.Facility := Ada_Facility;
if Task_Value /= null then
EVCB.Value := Unsigned_Longword (Task_Value.Known_Tasks_Index + 1);
else
EVCB.Value := 0;
end if;
EVCB.Sub_Event := 0;
EVCB.P1 := 0;
EVCB.Sigargs := 0;
EVCB.Flags := 0;
EVCB.Unused1 := 0;
EVCB.Unused2 := 0;
Signal (SS_DBGEVENT, 1, To_UL (EVCB));
end if;
end Signal_Debug_Event;
--------------------
-- Stop_All_Tasks --
--------------------
procedure Stop_All_Tasks is
begin
null; -- VxWorks
end Stop_All_Tasks;
----------------------------
-- Stop_All_Tasks_Handler --
----------------------------
procedure Stop_All_Tasks_Handler is
begin
null; -- VxWorks
end Stop_All_Tasks_Handler;
-----------------------
-- Suspend_All_Tasks --
-----------------------
procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
pragma Unreferenced (Thread_Self);
begin
null; -- VxWorks
end Suspend_All_Tasks;
------------------------
-- Task_Creation_Hook --
------------------------
procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is
pragma Unreferenced (Thread);
begin
null; -- VxWorks
end Task_Creation_Hook;
---------------------------
-- Task_Termination_Hook --
---------------------------
procedure Task_Termination_Hook is
begin
null; -- VxWorks
end Task_Termination_Hook;
-----------
-- Trace --
-----------
procedure Trace
(Self_Id : Task_Id;
Msg : String;
Flag : Character;
Other_Id : Task_Id := null)
is
begin
if Trace_On (Flag) then
Put (To_Integer (Self_Id)'Img &
':' & Flag & ':' &
Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len) &
':');
if Other_Id /= null then
Put (To_Integer (Other_Id)'Img & ':');
end if;
Put_Line (Msg);
end if;
end Trace;
------------------
-- Trace_Output --
------------------
procedure Trace_Output (Message_String : String) is
begin
if Trace_On ('V') and Trace_On ('M') and Trace_On ('S') then
Put_Output (Message_String);
end if;
end Trace_Output;
-----------
-- Write --
-----------
procedure Write (Fd : Integer; S : String; Count : Integer) is
Discard : System.CRTL.ssize_t;
pragma Unreferenced (Discard);
begin
Discard := System.CRTL.write (Fd, S (S'First)'Address,
System.CRTL.size_t (Count));
-- Is it really right to ignore write errors here ???
end Write;
end System.Tasking.Debug;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment