diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2011-12-15 15:28:47 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2011-12-15 15:28:47 +0000 |
| commit | 23d9fef246a4afde923f7085785ece2765682757 (patch) | |
| tree | 24bda10610cfd6725c0ec72e45209ee9f204e755 /gcc | |
| parent | c2d2ce08f88403e1a484bad67d4942b882354b95 (diff) | |
| download | ppe42-gcc-23d9fef246a4afde923f7085785ece2765682757.tar.gz ppe42-gcc-23d9fef246a4afde923f7085785ece2765682757.zip | |
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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@182374 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 6 | ||||
| -rw-r--r-- | gcc/ada/a-numaux-vms.ads | 104 | ||||
| -rw-r--r-- | gcc/ada/s-asthan-vms-ia64.adb | 608 | ||||
| -rw-r--r-- | gcc/ada/s-auxdec-vms-ia64.adb | 576 | ||||
| -rw-r--r-- | gcc/ada/s-memory-vms_64.adb | 230 | ||||
| -rw-r--r-- | gcc/ada/s-memory-vms_64.ads | 129 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-vms-ia64.adb | 58 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-vms-ia64.ads | 652 | ||||
| -rw-r--r-- | gcc/ada/s-tasdeb-vms.adb | 2158 |
9 files changed, 4521 insertions, 0 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ffc91dee409..5c936f2fc6a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +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> * aspects.adb, aspects.ads Aspect_Dimension and diff --git a/gcc/ada/a-numaux-vms.ads b/gcc/ada/a-numaux-vms.ads new file mode 100644 index 00000000000..7cd7cfeb255 --- /dev/null +++ b/gcc/ada/a-numaux-vms.ads @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-asthan-vms-ia64.adb b/gcc/ada/s-asthan-vms-ia64.adb new file mode 100644 index 00000000000..e5cdfaeee67 --- /dev/null +++ b/gcc/ada/s-asthan-vms-ia64.adb @@ -0,0 +1,608 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-auxdec-vms-ia64.adb b/gcc/ada/s-auxdec-vms-ia64.adb new file mode 100644 index 00000000000..86bec06f2a9 --- /dev/null +++ b/gcc/ada/s-auxdec-vms-ia64.adb @@ -0,0 +1,576 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-memory-vms_64.adb b/gcc/ada/s-memory-vms_64.adb new file mode 100644 index 00000000000..d725e31a83a --- /dev/null +++ b/gcc/ada/s-memory-vms_64.adb @@ -0,0 +1,230 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-memory-vms_64.ads b/gcc/ada/s-memory-vms_64.ads new file mode 100644 index 00000000000..c07a9dcfc4b --- /dev/null +++ b/gcc/ada/s-memory-vms_64.ads @@ -0,0 +1,129 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-osinte-vms-ia64.adb b/gcc/ada/s-osinte-vms-ia64.adb new file mode 100644 index 00000000000..e37d3d20b2f --- /dev/null +++ b/gcc/ada/s-osinte-vms-ia64.adb @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-osinte-vms-ia64.ads b/gcc/ada/s-osinte-vms-ia64.ads new file mode 100644 index 00000000000..99b91aa3455 --- /dev/null +++ b/gcc/ada/s-osinte-vms-ia64.ads @@ -0,0 +1,652 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-tasdeb-vms.adb b/gcc/ada/s-tasdeb-vms.adb new file mode 100644 index 00000000000..d0cb60f9687 --- /dev/null +++ b/gcc/ada/s-tasdeb-vms.adb @@ -0,0 +1,2158 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; |
