diff options
author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-05-14 10:02:00 +0000 |
---|---|---|
committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-05-14 10:02:00 +0000 |
commit | 3e55413dd9a577b7b270e04f09ccb3f13a90a3cb (patch) | |
tree | ad67eadab2c2032169ff2f33eb289b29a4e7e3a9 /gcc/ada/s-asthan-vms.adb | |
parent | 7e0c7e2e8e2c055a2751d8dbd5cdd4bd70fe316e (diff) | |
download | ppe42-gcc-3e55413dd9a577b7b270e04f09ccb3f13a90a3cb.tar.gz ppe42-gcc-3e55413dd9a577b7b270e04f09ccb3f13a90a3cb.zip |
Renaming of target specific files for clarity
* Makefile.in: Rename GNAT target specific files.
* 31soccon.ads, 31soliop.ads 35soccon.ads, 3asoccon.ads,
3bsoccon.ads, 3gsoccon.ads, 3hsoccon.ads, 3psoccon.ads,
3ssoccon.ads, 3ssoliop.ads, 3veacodu.adb, 3vexpect.adb,
3vsoccon.ads, 3vsocthi.adb, 3vsocthi.ads, 3vtrasym.adb,
3wsoccon.ads, 3wsocthi.adb, 3wsocthi.ads, 3wsoliop.ads,
3zsoccon.ads, 3zsocthi.adb, 3zsocthi.ads, 41intnam.ads,
42intnam.ads, 45intnam.ads, 4aintnam.ads, 4cintnam.ads,
4gintnam.ads, 4hexcpol.adb, 4hintnam.ads, 4lintnam.ads,
4nintnam.ads, 4ointnam.ads, 4onumaux.ads, 4pintnam.ads,
4sintnam.ads, 4vcaldel.adb, 4vcalend.adb, 4vcalend.ads,
4vintnam.ads, 4wcalend.adb, 4wexcpol.adb, 4wintnam.ads,
4zintnam.ads, 4znumaux.ads, 4zsytaco.adb, 4zsytaco.ads,
51osinte.adb, 51osinte.ads, 51system.ads,
52osinte.adb, 52osinte.ads, 53osinte.ads, 54osinte.ads,
55osinte.adb, 55osinte.ads, 55system.ads, 56osinte.adb,
56osinte.ads, 56system.ads, 56taprop.adb, 56taspri.ads,
56tpopsp.adb, 57system.ads, 58system.ads,
5amastop.adb, 5aml-tgt.adb, 5aosinte.adb, 5aosinte.ads,
5asystem.ads, 5ataprop.adb, 5atasinf.ads, 5ataspri.ads,
5atpopsp.adb, 5avxwork.ads, 5bml-tgt.adb, 5bosinte.adb,
5bosinte.ads, 5bsystem.ads, 5cosinte.ads, 5csystem.ads,
5dsystem.ads, 5esystem.ads, 5fintman.adb, 5fosinte.adb,
5fosinte.ads, 5fsystem.ads, 5ftaprop.adb, 5ftasinf.ads,
5ginterr.adb, 5gintman.adb, 5gmastop.adb, 5gml-tgt.adb,
5gosinte.ads, 5gproinf.adb, 5gproinf.ads, 5gsystem.ads,
5gtaprop.adb, 5gtasinf.adb, 5gtasinf.ads, 5gtpgetc.adb,
5hml-tgt.adb, 5hosinte.adb, 5hosinte.ads, 5hparame.ads,
5hsystem.ads, 5htaprop.adb, 5htaspri.ads, 5htraceb.adb,
5iosinte.adb, 5iosinte.ads, 5itaprop.adb, 5itaspri.ads,
5ksystem.ads, 5kvxwork.ads, 5lml-tgt.adb, 5losinte.ads,
5lparame.adb, 5lsystem.ads, 5msystem.ads, 5mvxwork.ads,
5ninmaop.adb, 5nintman.adb, 5nosinte.ads, 5nsystem.ads,
5ntaprop.adb, 5ntaspri.ads, 5ointerr.adb, 5omastop.adb,
5oosinte.adb, 5oosinte.ads, 5oosprim.adb, 5oparame.adb,
5osystem.ads, 5otaprop.adb, 5otaspri.ads, 5posinte.ads,
5posprim.adb, 5psystem.ads, 5pvxwork.ads, 5sintman.adb,
5sml-tgt.adb, 5sosinte.adb, 5sosinte.ads, 5sosprim.adb,
5sparame.adb, 5ssystem.ads, 5staprop.adb, 5stasinf.adb,
5stasinf.ads, 5staspri.ads, 5stpopsp.adb, 5svxwork.ads,
5tosinte.ads, 5usystem.ads, 5vasthan.adb, 5vdirval.adb,
5vinmaop.adb, 5vinterr.adb, 5vintman.adb, 5vintman.ads,
5vmastop.adb, 5vml-tgt.adb, 5vosinte.adb, 5vosinte.ads,
5vosprim.adb, 5vosprim.ads, 5vparame.ads, 5vsymbol.adb,
5vsystem.ads, 5vtaprop.adb, 5vtaspri.ads, 5vtpopde.adb,
5vtpopde.ads, 5vtraent.adb, 5vtraent.ads, 5vvaflop.adb,
5wdirval.adb, 5wgloloc.adb, 5wintman.adb, 5wmemory.adb,
5wml-tgt.adb, 5wosinte.ads, 5wosprim.adb, 5wsystem.ads,
5wtaprop.adb, 5wtaspri.ads, 5xparame.ads, 5xsystem.ads,
5xvxwork.ads, 5yparame.ads, 5ysystem.ads, 5zinterr.adb,
5zintman.adb, 5zintman.ads, 5zml-tgt.adb, 5zosinte.adb,
5zosinte.ads, 5zosprim.adb, 5zparame.ads, 5zstchop.adb,
5zsystem.ads, 5ztaprop.adb, 5ztaspri.ads, 5ztfsetr.adb,
5ztpopsp.adb, 6vcpp.adb, 6vcstrea.adb, 6vinterf.ads,
7sinmaop.adb, 7sintman.adb, 7sosinte.adb, 7sosprim.adb,
7staprop.adb, 7staspri.ads, 7stfsetr.adb, 7stpopsp.adb,
7straceb.adb, 7straces.adb, 7strafor.adb, 7strafor.ads,
7stratas.adb, 86numaux.adb, 86numaux.ads: Replaced by files below.
* a-caldel-vms.adb, a-calend-mingw.adb, a-calend-vms.adb,
a-calend-vms.ads, a-dirval-mingw.adb, a-dirval-vms.adb,
a-excpol-abort.adb, a-excpol-interix.adb, a-intnam-aix.ads,
a-intnam-dummy.ads, a-intnam-freebsd.ads, a-intnam-hpux.ads,
a-intnam-interix.ads, a-intnam-irix.ads, a-intnam-linux.ads,
a-intnam-lynxos.ads, a-intnam-mingw.ads, a-intnam-os2.ads,
a-intnam-solaris.ads, a-intnam-tru64.ads, a-intnam-unixware.ads,
a-intnam-vms.ads, a-intnam-vxworks.ads, a-numaux-libc-x86.ads,
a-numaux-vxworks.ads, a-numaux-x86.adb, a-numaux-x86.ads,
a-sytaco-vxworks.adb, a-sytaco-vxworks.ads, g-eacodu-vms.adb,
g-expect-vms.adb, g-soccon-aix.ads, g-soccon-freebsd.ads,
g-soccon-hpux.ads, g-soccon-interix.ads, g-soccon-irix.ads,
g-soccon-mingw.ads, g-soccon-solaris.ads, g-soccon-tru64.ads,
g-soccon-unixware.ads, g-soccon-vms.adb, g-soccon-vxworks.ads,
g-socthi-mingw.adb, g-socthi-mingw.ads, g-socthi-vms.adb,
g-socthi-vms.ads, g-socthi-vxworks.adb, g-socthi-vxworks.ads,
g-soliop-mingw.ads, g-soliop-solaris.ads, g-soliop-unixware.ads,
g-trasym-vms.adb, i-cpp-vms.adb, i-cstrea-vms.adb,
interfac-vms.ads, mlib-tgt-aix.adb, mlib-tgt-hpux.adb,
mlib-tgt-irix.adb, mlib-tgt-linux.adb, mlib-tgt-mingw.adb,
mlib-tgt-solaris.adb, mlib-tgt-tru64.adb, mlib-tgt-vms.adb,
mlib-tgt-vxworks.adb, s-asthan-vms.adb, s-gloloc-mingw.adb,
s-inmaop-dummy.adb, s-inmaop-posix.adb, s-inmaop-vms.adb,
s-interr-dummy.adb, s-interr-sigaction.adb, s-interr-vms.adb,
s-interr-vxworks.adb, s-intman-dummy.adb, s-intman-irix.adb,
s-intman-irix-athread.adb, s-intman-mingw.adb, s-intman-posix.adb,
s-intman-solaris.adb, s-intman-vms.adb, s-intman-vms.ads,
s-intman-vxworks.adb, s-intman-vxworks.ads, s-mastop-irix.adb,
s-mastop-tru64.adb, s-mastop-vms.adb, s-mastop-x86.adb,
s-memory-mingw.adb, s-osinte-aix.adb, s-osinte-aix.ads,
s-osinte-aix-fsu.ads, s-osinte-dummy.ads, s-osinte-freebsd.adb,
s-osinte-freebsd.ads, s-osinte-fsu.adb, s-osinte-hpux.ads,
s-osinte-hpux-dce.adb, s-osinte-hpux-dce.ads, s-osinte-interix.ads,
s-osinte-irix.adb, s-osinte-irix.ads, s-osinte-irix-athread.ads,
s-osinte-linux.ads, s-osinte-linux-fsu.ads, s-osinte-linux-ia64.ads,
s-osinte-lynxos-3.adb, s-osinte-lynxos-3.ads, s-osinte-lynxos.adb,
s-osinte-lynxos.ads, s-osinte-mingw.ads, s-osinte-os2.adb,
s-osinte-os2.ads, s-osinte-posix.adb, s-osinte-solaris.adb,
s-osinte-solaris.ads, s-osinte-solaris-fsu.ads,
s-osinte-solaris-posix.ads, s-osinte-tru64.adb, s-osinte-tru64.ads,
s-osinte-unixware.adb, s-osinte-unixware.ads, s-osinte-vms.adb,
s-osinte-vms.ads, s-osinte-vxworks.adb,
s-osinte-vxworks.ads, s-osprim-mingw.adb,
s-osprim-os2.adb, s-osprim-posix.adb, s-osprim-solaris.adb,
s-osprim-unix.adb, s-osprim-vms.adb, s-osprim-vms.ads,
s-osprim-vxworks.adb, s-parame-ae653.ads, s-parame-hpux.ads,
s-parame-linux.adb, s-parame-os2.adb, s-parame-solaris.adb,
s-parame-vms.ads, s-parame-vms-restrict.ads, s-parame-vxworks.ads,
s-proinf-irix-athread.adb, s-proinf-irix-athread.ads,
s-stchop-vxworks.adb, s-taprop-dummy.adb,
s-taprop-hpux-dce.adb, s-taprop-irix.adb,
s-taprop-irix-athread.adb, s-taprop-linux.adb, s-taprop-lynxos.adb,
s-taprop-mingw.adb, s-taprop-os2.adb, s-taprop-posix.adb,
s-taprop-solaris.adb, s-taprop-tru64.adb, s-taprop-vms.adb,
s-taprop-vxworks.adb, s-tasinf-irix.ads, s-tasinf-irix-athread.adb,
s-tasinf-irix-athread.ads, s-tasinf-solaris.adb, s-tasinf-solaris.ads,
s-tasinf-tru64.ads, s-taspri-dummy.ads, s-taspri-hpux-dce.ads,
s-taspri-linux.ads, s-taspri-lynxos.ads, s-taspri-mingw.ads,
s-taspri-os2.ads, s-taspri-posix.ads, s-taspri-solaris.ads,
s-taspri-tru64.ads, s-taspri-vms.ads, s-taspri-vxworks.ads,
s-tfsetr-default.adb, s-tfsetr-vxworks.adb, s-tpopde-vms.adb,
s-tpopde-vms.ads, s-tpopsp-lynxos.adb, s-tpopsp-posix.adb,
s-tpopsp-posix-foreign.adb, s-tpopsp-solaris.adb, s-tpopsp-vxworks.adb,
s-traceb-hpux.adb, s-traceb-mastop.adb, s-traces-default.adb,
s-traent-vms.adb, s-traent-vms.ads, s-trafor-default.adb,
s-trafor-default.ads, s-tratas-default.adb, s-vaflop-vms.adb,
s-vxwork-alpha.ads, s-vxwork-m68k.ads, s-vxwork-mips.ads,
s-vxwork-ppc.ads, s-vxwork-sparcv9.ads, s-vxwork-xscale.ads,
symbols-vms.adb, system-aix.ads, system-freebsd-x86.ads,
system-hpux.ads, system-interix.ads, system-irix-n32.ads,
system-irix-o32.ads, system-linux-x86_64.ads,
system-linux-x86.ads, system-lynxos-ppc.ads, system-lynxos-x86.ads,
system-mingw.ads, system-os2.ads, system-solaris-sparc.ads,
system-solaris-sparcv9.ads, system-solaris-x86.ads, system-tru64.ads,
system-unixware.ads, system-vms.ads, system-vms-zcx.ads,
system-vxworks-alpha.ads, system-vxworks-m68k.ads,
system-vxworks-mips.ads, system-vxworks-ppc.ads,
system-vxworks-sparcv9.ads, system-vxworks-xscale.ads: Replace files
above.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@81834 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada/s-asthan-vms.adb')
-rw-r--r-- | gcc/ada/s-asthan-vms.adb | 597 |
1 files changed, 597 insertions, 0 deletions
diff --git a/gcc/ada/s-asthan-vms.adb b/gcc/ada/s-asthan-vms.adb new file mode 100644 index 00000000000..86d04025dbf --- /dev/null +++ b/gcc/ada/s-asthan-vms.adb @@ -0,0 +1,597 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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/Alpha version. + +with System; use System; + +with System.IO; + +with System.Machine_Code; +with System.Parameters; +with System.Storage_Elements; + +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; +-- removed, because of problem with controlled attribute ??? + +with Ada.Task_Attributes; +with Ada.Task_Identification; + +with Ada.Exceptions; use Ada.Exceptions; + +with Ada.Unchecked_Conversion; + +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 SSE renames System.Storage_Elements; + 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/Alpha, procedure pointers do not in + -- fact point to code, but rather to a 48-byte procedure descriptor. + -- So a value of type AST_Handler is in fact a pointer to one of these + -- 48-byte descriptors. + + type Descriptor_Type is new SSE.Storage_Array (1 .. 48); + 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 +-- removed due to problem with controlled attribute, consequence is that +-- we have a memory leak if a task that has AST attribute entries is +-- terminated. ??? + + type AST_Vector_Ptr is record + Vector : AST_Handler_Vector_Ref; + end record; + + 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 := + Original_Descriptor_Ref.all; + 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 : in 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.Address); + + begin + System.Machine_Code.Asm + (Template => "addl $27,0,%0", + Outputs => AST_Handler_Data_Ref'Asm_Output ("=r", Handler_Data_Ptr), + Volatile => True); + + System.Machine_Code.Asm + (Template => "ldl $27,%0", + Inputs => Descriptor_Ref'Asm_Input + ("m", Handler_Data_Ptr.Original_Descriptor_Ref), + 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; |