* s-asthan-vms.adb: Removed.
* s-asthan-vms-alpha.adb: Added.
* Makefile.in [VMS] (LN,LN_S): Define as cp -p
Rename s-asthan-vms.adb to s-asthan-vms-alpha.adb.
[VMS]: Add translations for g-enblsp.adb.
(LIBGNAT_SRCS): Add seh_init.c.
(LIBGNAT_OBJS): Add seh_init.o.
PR ada/16592
Link all gnat tools with -static-libgcc, since
-shared-libgcc is now used by default on some systems (e.g. linux with
recent binutils).
Remove references to Makefile.prolog/generic, no longer used.
From-SVN: r94818
program_transform_name =
objdir = .
+target_alias=@target_alias@
target=@target@
xmake_file = @xmake_file@
tmake_file = @tmake_file@
soext = .exe
hyphen = _
+LN = cp -p
+LN_S = cp -p
ifeq ($(strip $(filter-out ia64 hp vms% openvms%,$(targ))),)
AR = iar
ifeq ($(strip $(filter-out alpha% ia64 dec hp vms% openvms% alphavms%,$(targ))),)
ifeq ($(strip $(filter-out ia64 hp vms% openvms%,$(targ))),)
LIBGNAT_TARGET_PAIRS_AUX1 = \
+ g-enblsp.adb<g-enblsp-vms-ia64.adb \
s-auxdec.ads<s-auxdec-vms_64.ads \
s-crtl.ads<s-crtl-vms.ads \
s-osinte.adb<s-osinte-vms-ia64.adb \
else
ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(targ))),)
LIBGNAT_TARGET_PAIRS_AUX1 = \
+ g-enblsp.adb<g-enblsp-vms-alpha.adb \
+ s-asthan.adb<s-asthan-vms-alpha.adb \
s-crtl.ads<s-crtl-vms.ads \
s-osinte.adb<s-osinte-vms.adb \
s-osinte.ads<s-osinte-vms.ads \
i-cstrea.adb<i-cstrea-vms.adb \
i-cpp.adb<i-cpp-vms.adb \
interfac.ads<interfac-vms.ads \
- s-asthan.adb<s-asthan-vms.adb \
s-inmaop.adb<s-inmaop-vms.adb \
s-interr.adb<s-interr-vms.adb \
s-intman.adb<s-intman-vms.adb \
EXTRA_GNATRTL_TASKING_OBJS=s-tpopde.o
EXTRA_GNATTOOLS = \
../../gnatlbr$(exeext) \
- ,,/../gnatsym$(exeext)
+ ../../gnatsym$(exeext)
# This command transforms (YYYYMMDD) into YY,MMDD
GSMATCH_VERSION := $(shell grep "^ *Gnat_Static_Version_String" $(fsrcpfx)gnatvsn.ads | sed -e 's/.*(\(.*\)).*/\1/' -e 's/\(..\)\(..\)\(....\)/\2,\3/')
TOOLS_LIBS_LO := --for-linker=sys\\$$\$$library:trace.exe
GMEM_LIB = gmemlib
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
LIBRARY_VERSION := $(LIB_VERSION)
-
endif
ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),)
# subdirectory and copied.
LIBGNAT_SRCS = ada.h adaint.c adaint.h argv.c cio.c cstreams.c \
errno.c exit.c cal.c ctrl_c.c \
- raise.h raise.c sysdep.c aux-io.c init.c \
+ raise.h raise.c sysdep.c aux-io.c init.c seh_init.c \
final.c tracebak.c tb-alvms.c tb-alvxw.c expect.c mkdir.c socket.c gsocket.h \
$(EXTRA_LIBGNAT_SRCS)
LIBGNAT_OBJS = adaint.o argv.o cio.o cstreams.o ctrl_c.o errno.o exit.o \
- raise.o sysdep.o aux-io.o init.o cal.o final.o \
+ raise.o sysdep.o aux-io.o init.o seh_init.o cal.o final.o \
tracebak.o expect.o mkdir.o socket.o $(EXTRA_LIBGNAT_OBJS)
# NOTE ??? - when the -I option for compiling Ada code is made to work,
ADA_INCLUDE_SRCS =\
ada.ads calendar.ads directio.ads gnat.ads interfac.ads ioexcept.ads \
machcode.ads text_io.ads unchconv.ads unchdeal.ads \
- sequenio.ads system.ads Makefile.prolog Makefile.generic \
- memtrack.adb \
+ sequenio.ads system.ads Makefile.adalib memtrack.adb \
a-*.adb a-*.ads g-*.ad? i-*.ad? \
s-[a-o]*.adb s-[p-z]*.adb \
s-[a-o]*.ads s-[p-z]*.ads
"GNATLINK=$(GNATLINK)" \
"GNATBIND=$(GNATBIND)"
+GCC_LINK="$(CC) -static-libgcc $(ADA_INCLUDES)"
+
# Build directory for the tools. Let's copy the target-dependent
# sources using the same mechanism as for gnatlib. The other sources are
# accessed using the vpath directive below
../../gnatchop$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatchop --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatchop
- $(GNATLINK) -v gnatchop -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
- $(TOOLS_LIBS)
+ $(GNATLINK) -v gnatchop -o $@ --GCC=$(GCC_LINK) $(TOOLS_LIBS)
../../gnat$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatcmd --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatcmd
- $(GNATLINK) -v gnatcmd -o $@ --GCC="$(CC) $(ADA_INCLUDES)" $(TOOLS_LIBS)
+ $(GNATLINK) -v gnatcmd -o $@ --GCC=$(GCC_LINK) $(TOOLS_LIBS)
../../gnatkr$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatkr --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatkr
- $(GNATLINK) -v gnatkr -o $@ --GCC="$(CC) $(ADA_INCLUDES)" $(TOOLS_LIBS)
+ $(GNATLINK) -v gnatkr -o $@ --GCC=$(GCC_LINK) $(TOOLS_LIBS)
../../gnatls$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatls --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatls
- $(GNATLINK) -v gnatls -o $@ --GCC="$(CC) $(ADA_INCLUDES)" $(TOOLS_LIBS)
+ $(GNATLINK) -v gnatls -o $@ --GCC=$(GCC_LINK) $(TOOLS_LIBS)
../../gnatname$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatname --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatname
- $(GNATLINK) -v gnatname -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
- $(TOOLS_LIBS)
+ $(GNATLINK) -v gnatname -o $@ --GCC=$(GCC_LINK) $(TOOLS_LIBS)
../../gprmake$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gprmake --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gprmake
- $(GNATLINK) -v gprmake -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
- $(TOOLS_LIBS)
+ $(GNATLINK) -v gprmake -o $@ --GCC=$(GCC_LINK) $(TOOLS_LIBS)
../../gnatprep$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatprep --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatprep
- $(GNATLINK) -v gnatprep -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
- $(TOOLS_LIBS)
+ $(GNATLINK) -v gnatprep -o $@ --GCC=$(GCC_LINK) $(TOOLS_LIBS)
../../gnatxref$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatxref --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatxref
- $(GNATLINK) -v gnatxref -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
- $(TOOLS_LIBS)
+ $(GNATLINK) -v gnatxref -o $@ --GCC=$(GCC_LINK) $(TOOLS_LIBS)
../../gnatfind$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatfind --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatfind
- $(GNATLINK) -v gnatfind -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
- $(TOOLS_LIBS)
+ $(GNATLINK) -v gnatfind -o $@ --GCC=$(GCC_LINK) $(TOOLS_LIBS)
../../gnatclean$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatclean --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatclean
- $(GNATLINK) -v gnatclean -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
- $(TOOLS_LIBS)
+ $(GNATLINK) -v gnatclean -o $@ --GCC=$(GCC_LINK) $(TOOLS_LIBS)
../../gnatsym$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatsym --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatsym
- $(GNATLINK) -v gnatsym -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
- $(TOOLS_LIBS)
+ $(GNATLINK) -v gnatsym -o $@ --GCC=$(GCC_LINK) $(TOOLS_LIBS)
../../gnatdll$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatdll --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) $(GNATBIND_FLAGS) gnatdll
- $(GNATLINK) -v gnatdll -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
- $(TOOLS_LIBS)
+ $(GNATLINK) -v gnatdll -o $@ --GCC=$(GCC_LINK) $(TOOLS_LIBS)
../../vxaddr2line$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) vxaddr2line --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) vxaddr2line
- $(GNATLINK) -v vxaddr2line -o $@ --GCC="$(CC) $(ADA_INCLUDES)" $(CLIB)
+ $(GNATLINK) -v vxaddr2line -o $@ --GCC=$(GCC_LINK) $(CLIB)
gnatmake-re: ../stamp-tools link.o
$(GNATMAKE) $(ADA_INCLUDES) -u sdefault --GCC="$(CC) $(MOST_ADA_FLAGS)"
$(GNATMAKE) -c $(ADA_INCLUDES) gnatmake --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatmake
$(GNATLINK) -v gnatmake -o ../../gnatmake$(exeext) \
- --GCC="$(CC) $(ADA_INCLUDES)" $(TOOLS_LIBS)
+ --GCC=$(GCC_LINK) $(TOOLS_LIBS)
# Note the use of the "mv" command in order to allow gnatlink to be linked with
# with the former version of gnatlink itself which cannot override itself.
$(GNATMAKE) -c $(ADA_INCLUDES) gnatlink --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatlink
$(GNATLINK) -v gnatlink -o ../../gnatlinknew$(exeext) \
- --GCC="$(CC) $(ADA_INCLUDES)" $(TOOLS_LIBS)
+ --GCC=$(GCC_LINK) $(TOOLS_LIBS)
$(MV) ../../gnatlinknew$(exeext) ../../gnatlink$(exeext)
# Needs to be built with CC=gcc
# deleting the right one.
-$(MKDIR) $(DESTDIR)$(ADA_RTL_OBJ_DIR)
-$(MKDIR) $(DESTDIR)$(ADA_INCLUDE_DIR)
- -$(MKDIR) $(DESTDIR)$(ADA_SHARE_MAKE_DIR)
$(RMDIR) $(DESTDIR)$(ADA_RTL_OBJ_DIR)
$(RMDIR) $(DESTDIR)$(ADA_INCLUDE_DIR)
- $(RMDIR) $(DESTDIR)$(ADA_SHARE_MAKE_DIR)
-$(MKDIR) $(DESTDIR)$(ADA_RTL_OBJ_DIR)
-$(MKDIR) $(DESTDIR)$(ADA_INCLUDE_DIR)
- -$(MKDIR) $(DESTDIR)$(ADA_SHARE_MAKE_DIR)
- -$(INSTALL_DATA) rts/Makefile.prolog $(DESTDIR)$(ADA_SHARE_MAKE_DIR)
- -$(INSTALL_DATA) rts/Makefile.generic $(DESTDIR)$(ADA_SHARE_MAKE_DIR)
for file in rts/*.ali; do \
$(INSTALL_DATA_DATE) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
done
ADA_INCLUDE_DIR = $(libsubdir)/adainclude
ADA_RTL_OBJ_DIR = $(libsubdir)/adalib
-ADA_SHARE_MAKE_DIR = $(prefix)/share/gnat
# force no sibling call optimization on s-traceb.o so the number of stack
# frames to be skipped when computing a call chain is not modified by
socket.o : socket.c gsocket.h
sysdep.o : sysdep.c
-cio.o : cio.c
+gen-soccon: gen-soccon.c gsocket.h
+ $(CC) $(ALL_CFLAGS) $(ADA_CFLAGS) $(RT_FLAGS) \
+ $(ALL_CPPFLAGS) $(INCLUDES) -DTARGET=\"$(target_alias)\" \
+ $< $(OUTPUT_OPTION)
+
+cio.o : cio.c
$(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(RT_FLAGS) \
$(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION)
$(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(RT_FLAGS) \
$(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION)
+# No optimization to compile this file as optimizations (-O1 or above) breaks
+# the SEH handling on Windows. The reasons are not clear.
+seh_init.o : seh_init.c raise.h
+ $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(RT_FLAGS) -O0 \
+ $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION)
+
raise.o : raise.c raise.h
$(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(RT_FLAGS) \
$(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION)
../../gnatlbr$(exeext): ../../prefix.o
$(GNATMAKE) -c $(ADA_INCLUDES) gnatlbr --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatlbr
- $(GNATLINK) -v gnatlbr -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
- $(TOOLS_LIBS)
+ $(GNATLINK) -v gnatlbr -o $@ --GCC=$(GCC_LINK) $(TOOLS_LIBS)
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
projects / gcc.git / commitdiff