diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 28 | ||||
| -rw-r--r-- | gcc/ada/a-intnam-tru64.ads | 151 | ||||
| -rw-r--r-- | gcc/ada/adaint.c | 6 | ||||
| -rw-r--r-- | gcc/ada/env.c | 10 | ||||
| -rw-r--r-- | gcc/ada/g-traceb.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/g-trasym.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/Makefile.in | 28 | ||||
| -rw-r--r-- | gcc/ada/gnat_ugn.texi | 7 | ||||
| -rw-r--r-- | gcc/ada/gsocket.h | 9 | ||||
| -rw-r--r-- | gcc/ada/init.c | 150 | ||||
| -rw-r--r-- | gcc/ada/link.c | 16 | ||||
| -rw-r--r-- | gcc/ada/memtrack.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/mlib-tgt-specific-tru64.adb | 168 | ||||
| -rw-r--r-- | gcc/ada/s-mastop-tru64.adb | 163 | ||||
| -rw-r--r-- | gcc/ada/s-oscons-tmplt.c | 25 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-tru64.adb | 142 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-tru64.ads | 585 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-tru64.adb | 1365 | ||||
| -rw-r--r-- | gcc/ada/s-tasinf-tru64.ads | 110 | ||||
| -rw-r--r-- | gcc/ada/s-taspri-tru64.ads | 119 | ||||
| -rw-r--r-- | gcc/ada/sysdep.c | 10 | ||||
| -rw-r--r-- | gcc/ada/system-tru64.ads | 214 | ||||
| -rw-r--r-- | gcc/ada/terminals.c | 17 |
23 files changed, 46 insertions, 3286 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3989168aaa7..2593ef29de8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,31 @@ +2012-03-12 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + * gcc-interface/Makefile.in (alpha*-dec-osf*): Remove. + * a-intnam-tru64.ads, mlib-tgt-specific-tru64.adb, + s-mastop-tru64.adb, s-osinte-tru64.adb, s-osinte-tru64.ads, + s-taprop-tru64.adb, s-tasinf-tru64.ads, s-taspri-tru64.ads, + system-tru64.ads: Remove. + + * adaint.c (__gnat_number_of_cpus) [__alpha__ && __osf__]: + Remove. + [IS_CROSS] [!(__alpha__ && __osf__)]: Remove. + * env.c [__alpha__ && __osf__]: Remove. + * gsocket.h (_OSF_SOURCE): Remove. + (HAVE_THREAD_SAFE_GETxxxBYyyy) [__osf__]: Remove. + * init.c [__alpha__ && __osf__]: Remove. + * link.c [__osf__]: Remove. + * s-oscons-tmplt.c [__alpha__ && __osf__]: Remove. + [__osf__ && !_SS_MAXSIZE]: Remove. + * sysdep.c [__osf__]: Remove. + * terminals.c [__alpha__ && __osf__]: Remove. + [OSF1]: Remove. + + * g-traceb.ads: Remove Tru64 reference. + * g-trasym.ads: Likewise. + * gnat_ugn.texi (Linking a Mixed C++ & Ada Program): Likewise. + (Summary of Run-Time Configurations): Likewise. + * memtrack.adb: Likewise. + 2012-03-12 Tristan Gingold <gingold@adacore.com> * gcc-interface/decl.c (gnat_to_gnu_param): Use flag_vms_malloc64 diff --git a/gcc/ada/a-intnam-tru64.ads b/gcc/ada/a-intnam-tru64.ads deleted file mode 100644 index 3ea1a4afd7c..00000000000 --- a/gcc/ada/a-intnam-tru64.ads +++ /dev/null @@ -1,151 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-2011, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 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 the DEC Unix 4.0 version of this package - --- The following signals are reserved by the run time: - --- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGALRM, --- SIGSTOP, SIGKILL - --- The pragma Unreserve_All_Interrupts affects the following signal(s): - --- SIGINT: made available for Ada handler - -with System.OS_Interface; - -package Ada.Interrupts.Names is - - -- All identifiers in this unit are implementation defined - - pragma Implementation_Defined; - - -- Beware that the mapping of names to signals may be many-to-one. There - -- may be aliases. Also, for all signal names that are not supported on the - -- current system the value of the corresponding constant will be zero. - - SIGHUP : constant Interrupt_ID := - System.OS_Interface.SIGHUP; -- hangup - - SIGINT : constant Interrupt_ID := - System.OS_Interface.SIGINT; -- interrupt (rubout) - - SIGQUIT : constant Interrupt_ID := - System.OS_Interface.SIGQUIT; -- quit (ASCD FS) - - SIGILL : constant Interrupt_ID := - System.OS_Interface.SIGILL; -- illegal instruction (not reset) - - SIGTRAP : constant Interrupt_ID := - System.OS_Interface.SIGTRAP; -- trace trap (not reset) - - SIGIOT : constant Interrupt_ID := - System.OS_Interface.SIGIOT; -- IOT instruction - - SIGABRT : constant Interrupt_ID := -- used by abort, - System.OS_Interface.SIGABRT; -- replace SIGIOT in the future - - SIGEMT : constant Interrupt_ID := - System.OS_Interface.SIGEMT; -- EMT instruction - - SIGFPE : constant Interrupt_ID := - System.OS_Interface.SIGFPE; -- floating point exception - - SIGKILL : constant Interrupt_ID := - System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) - - SIGBUS : constant Interrupt_ID := - System.OS_Interface.SIGBUS; -- bus error - - SIGSEGV : constant Interrupt_ID := - System.OS_Interface.SIGSEGV; -- segmentation violation - - SIGSYS : constant Interrupt_ID := - System.OS_Interface.SIGSYS; -- bad argument to system call - - SIGPIPE : constant Interrupt_ID := -- write on a pipe with - System.OS_Interface.SIGPIPE; -- no one to read it - - SIGALRM : constant Interrupt_ID := - System.OS_Interface.SIGALRM; -- alarm clock - - SIGTERM : constant Interrupt_ID := - System.OS_Interface.SIGTERM; -- software termination signal from kill - - SIGUSR1 : constant Interrupt_ID := - System.OS_Interface.SIGUSR1; -- user defined signal 1 - - SIGUSR2 : constant Interrupt_ID := - System.OS_Interface.SIGUSR2; -- user defined signal 2 - - SIGCHLD : constant Interrupt_ID := - System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD - - SIGWINCH : constant Interrupt_ID := - System.OS_Interface.SIGWINCH; -- window size change - - SIGURG : constant Interrupt_ID := - System.OS_Interface.SIGURG; -- urgent condition on IO channel - - SIGPOLL : constant Interrupt_ID := - System.OS_Interface.SIGPOLL; -- pollable event occurred - - SIGIO : constant Interrupt_ID := -- input/output possible, - System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) - - SIGSTOP : constant Interrupt_ID := - System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) - - SIGTSTP : constant Interrupt_ID := - System.OS_Interface.SIGTSTP; -- user stop requested from tty - - SIGCONT : constant Interrupt_ID := - System.OS_Interface.SIGCONT; -- stopped process has been continued - - SIGTTIN : constant Interrupt_ID := - System.OS_Interface.SIGTTIN; -- background tty read attempted - - SIGTTOU : constant Interrupt_ID := - System.OS_Interface.SIGTTOU; -- background tty write attempted - - SIGVTALRM : constant Interrupt_ID := - System.OS_Interface.SIGVTALRM; -- virtual timer expired - - SIGPROF : constant Interrupt_ID := - System.OS_Interface.SIGPROF; -- profiling timer expired - - SIGXCPU : constant Interrupt_ID := - System.OS_Interface.SIGXCPU; -- CPU time limit exceeded - - SIGXFSZ : constant Interrupt_ID := - System.OS_Interface.SIGXFSZ; -- filesize limit exceeded - -end Ada.Interrupts.Names; diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 4c96d56b1ce..8309123ce4e 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2011, Free Software Foundation, Inc. * + * Copyright (C) 1992-2012, 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- * @@ -2467,8 +2467,7 @@ __gnat_number_of_cpus (void) { int cores = 1; -#if defined (linux) || defined (sun) || defined (AIX) \ - || (defined (__alpha__) && defined (_osf_)) || defined (__APPLE__) +#if defined (linux) || defined (sun) || defined (AIX) || defined (__APPLE__) cores = (int) sysconf (_SC_NPROCESSORS_ONLN); #elif (defined (__mips) && defined (__sgi)) @@ -3541,7 +3540,6 @@ _flush_cache() && ! defined (__hpux__) \ && ! defined (__APPLE__) \ && ! defined (_AIX) \ - && ! (defined (__alpha__) && defined (__osf__)) \ && ! defined (VMS) \ && ! defined (__MINGW32__) \ && ! (defined (__mips) && defined (__sgi))) diff --git a/gcc/ada/env.c b/gcc/ada/env.c index 31c878e7795..ac7ee21b384 100644 --- a/gcc/ada/env.c +++ b/gcc/ada/env.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 2005-2011, Free Software Foundation, Inc. * + * Copyright (C) 2005-2012, 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- * @@ -29,14 +29,6 @@ * * ****************************************************************************/ -/* Tru64 UNIX V4.0F <stdlib.h> declares unsetenv() only if AES_SOURCE (which - is plain broken, this should be _AES_SOURCE instead as everywhere else; - Tru64 UNIX V5.1B declares it only if _BSD. */ -#if defined (__alpha__) && defined (__osf__) -#define AES_SOURCE -#define _BSD -#endif - #ifdef __cplusplus extern "C" { #endif diff --git a/gcc/ada/g-traceb.ads b/gcc/ada/g-traceb.ads index 6c4d6b10efc..3397014ff27 100644 --- a/gcc/ada/g-traceb.ads +++ b/gcc/ada/g-traceb.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2010, AdaCore -- +-- Copyright (C) 1999-2012, AdaCore -- -- -- -- 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- -- @@ -64,7 +64,6 @@ -- LynxOS x86 -- Solaris x86 -- Solaris sparc --- Tru64 alpha -- OpenVMS/Alpha -- OpenVMS/ia64 -- VxWorks PowerPC diff --git a/gcc/ada/g-trasym.ads b/gcc/ada/g-trasym.ads index 4b30600adb3..1cc6551d457 100644 --- a/gcc/ada/g-trasym.ads +++ b/gcc/ada/g-trasym.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2011, AdaCore -- +-- Copyright (C) 1999-2012, AdaCore -- -- -- -- 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- -- @@ -38,7 +38,6 @@ -- GNU/Linux x86, x86_64, ia64 -- FreeBSD x86, x86_64 -- Solaris sparc and x86 --- Tru64 -- OpenVMS Alpha and ia64 -- Windows diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index eb6e7bcdd45..75d80c518bf 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -1454,34 +1454,6 @@ ifeq ($(strip $(filter-out rtems%,$(osys))),) s-interr.adb<s-interr-hwint.adb endif -ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),) - LIBGNAT_TARGET_PAIRS = \ - a-intnam.ads<a-intnam-tru64.ads \ - s-inmaop.adb<s-inmaop-posix.adb \ - s-intman.adb<s-intman-posix.adb \ - s-mastop.adb<s-mastop-tru64.adb \ - s-osinte.adb<s-osinte-tru64.adb \ - s-osinte.ads<s-osinte-tru64.ads \ - s-osprim.adb<s-osprim-unix.adb \ - s-taprop.adb<s-taprop-tru64.adb \ - s-tasinf.ads<s-tasinf-tru64.ads \ - s-taspri.ads<s-taspri-tru64.ads \ - s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ - s-traceb.adb<s-traceb-mastop.adb \ - system.ads<system-tru64.ads \ - $(ATOMICS_TARGET_PAIRS) \ - $(ATOMICS_BUILTINS_TARGET_PAIRS) - - TOOLS_TARGET_PAIRS=mlib-tgt-specific.adb<mlib-tgt-specific-tru64.adb - - EH_MECHANISM=-gcc - GMEM_LIB=gmemlib - MISCLIB = -lexc - THREADSLIB = -lpthread -lmach -lexc -lrt - GNATLIB_SHARED = gnatlib-shared-default - LIBRARY_VERSION := $(LIB_VERSION) -endif - ifeq ($(strip $(filter-out alpha64 ia64 dec hp vms% openvms% alphavms%,$(host))),) soext = .exe diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 6885eed89d2..e6f368bcb48 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -3092,7 +3092,7 @@ $ gnatlink ada_unit file1.o file2.o --LINK=./my_script If the @code{zero cost} exception mechanism is used, and the platform doesn't support automatic registration of exception tables (e.g.@: HP-UX, -Tru64 or AIX), the simple approach described above will not work and +or AIX), the simple approach described above will not work and a pre-linking phase using GNAT will be necessary. @end enumerate @@ -22164,11 +22164,6 @@ information about several specific platforms. @item @code{@ @ @ @ }Tasking @tab native VMS threads @item @code{@ @ @ @ }Exceptions @tab ZCX @* -@item @b{alpha-tru64} -@item @code{@ @ }@i{rts-native (default)} -@item @code{@ @ @ @ }Tasking @tab native TRU64 threads -@item @code{@ @ @ @ }Exceptions @tab ZCX -@* @item @code{@ @ }@i{rts-sjlj} @item @code{@ @ @ @ }Tasking @tab native TRU64 threads @item @code{@ @ @ @ }Exceptions @tab SJLJ diff --git a/gcc/ada/gsocket.h b/gcc/ada/gsocket.h index a4507fe8804..4dfbee77f08 100644 --- a/gcc/ada/gsocket.h +++ b/gcc/ada/gsocket.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 2004-2011, Free Software Foundation, Inc. * + * Copyright (C) 2004-2012, 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- * @@ -53,11 +53,6 @@ /* For AIX */ #endif -#ifndef _OSF_SOURCE -#define _OSF_SOURCE 1 -/* For Tru64 */ -#endif - /** No system header may be included prior to this point since on some targets ** we need to redefine FD_SETSIZE. **/ @@ -204,7 +199,7 @@ #endif #if defined (_AIX) || defined (__FreeBSD__) || defined (__hpux__) || \ - defined (__osf__) || defined (_WIN32) || defined (__APPLE__) + defined (_WIN32) || defined (__APPLE__) # define HAVE_THREAD_SAFE_GETxxxBYyyy 1 #elif defined (sgi) || defined (linux) || defined (__GLIBC__) || \ diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 80a02b1734f..87124b6a4ea 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -295,156 +295,6 @@ __gnat_install_handler (void) } /*****************/ -/* Tru64 section */ -/*****************/ - -#elif defined(__alpha__) && defined(__osf__) - -#include <signal.h> -#include <sys/siginfo.h> - -extern char *__gnat_get_code_loc (struct sigcontext *); -extern void __gnat_set_code_loc (struct sigcontext *, char *); -extern size_t __gnat_machine_state_length (void); - -#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE - -void -__gnat_adjust_context_for_raise (int signo, void *ucontext) -{ - struct sigcontext *sigcontext = (struct sigcontext *) ucontext; - - /* The unwinder expects the signal context to contain the address of the - faulting instruction. For SIGFPE, this depends on the trap shadow - situation (see man ieee). We nonetheless always compensate for it, - considering that PC designates the instruction following the one that - trapped. This is not necessarily true but corresponds to what we have - always observed. */ - if (signo == SIGFPE) - sigcontext->sc_pc--; -} - -static void -__gnat_error_handler (int sig, siginfo_t *si, void *ucontext) -{ - struct Exception_Data *exception; - static int recurse = 0; - const char *msg; - - /* Adjusting is required for every fault context, so adjust for this one - now, before we possibly trigger a recursive fault below. */ - __gnat_adjust_context_for_raise (sig, ucontext); - - /* If this was an explicit signal from a "kill", just resignal it. */ - if (SI_FROMUSER (si)) - { - signal (sig, SIG_DFL); - kill (getpid(), sig); - } - - /* Otherwise, treat it as something we handle. */ - switch (sig) - { - case SIGSEGV: - /* If the problem was permissions, this is a constraint error. - Likewise if the failing address isn't maximally aligned or if - we've recursed. - - ??? Using a static variable here isn't task-safe, but it's - much too hard to do anything else and we're just determining - which exception to raise. */ - if (si->si_code == SEGV_ACCERR - || (long) si->si_addr == 0 - || (((long) si->si_addr) & 3) != 0 - || recurse) - { - exception = &constraint_error; - msg = "SIGSEGV"; - } - else - { - /* See if the page before the faulting page is accessible. Do that - by trying to access it. We'd like to simply try to access - 4096 + the faulting address, but it's not guaranteed to be - the actual address, just to be on the same page. */ - recurse++; - ((volatile char *) - ((long) si->si_addr & - getpagesize ()))[getpagesize ()]; - exception = &storage_error; - msg = "stack overflow or erroneous memory access"; - } - break; - - case SIGBUS: - exception = &program_error; - msg = "SIGBUS"; - break; - - case SIGFPE: - exception = &constraint_error; - msg = "SIGFPE"; - break; - - default: - exception = &program_error; - msg = "unhandled signal"; - } - - recurse = 0; - Raise_From_Signal_Handler (exception, CONST_CAST (char *, msg)); -} - -void -__gnat_install_handler (void) -{ - struct sigaction act; - - /* Setup signal handler to map synchronous signals to appropriate - exceptions. Make sure that the handler isn't interrupted by another - signal that might cause a scheduling event! */ - - act.sa_handler = (void (*) (int)) __gnat_error_handler; - act.sa_flags = SA_RESTART | SA_NODEFER | SA_SIGINFO; - sigemptyset (&act.sa_mask); - - /* Do not install handlers if interrupt state is "System". */ - if (__gnat_get_interrupt_state (SIGABRT) != 's') - sigaction (SIGABRT, &act, NULL); - if (__gnat_get_interrupt_state (SIGFPE) != 's') - sigaction (SIGFPE, &act, NULL); - if (__gnat_get_interrupt_state (SIGILL) != 's') - sigaction (SIGILL, &act, NULL); - if (__gnat_get_interrupt_state (SIGSEGV) != 's') - sigaction (SIGSEGV, &act, NULL); - if (__gnat_get_interrupt_state (SIGBUS) != 's') - sigaction (SIGBUS, &act, NULL); - - __gnat_handler_installed = 1; -} - -/* Routines called by s-mastop-tru64.adb. */ - -#define SC_GP 29 - -char * -__gnat_get_code_loc (struct sigcontext *context) -{ - return (char *) context->sc_pc; -} - -void -__gnat_set_code_loc (struct sigcontext *context, char *pc) -{ - context->sc_pc = (long) pc; -} - -size_t -__gnat_machine_state_length (void) -{ - return sizeof (struct sigcontext); -} - -/*****************/ /* HP-UX section */ /*****************/ diff --git a/gcc/ada/link.c b/gcc/ada/link.c index cb1a928584a..223147df7d2 100644 --- a/gcc/ada/link.c +++ b/gcc/ada/link.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2011, Free Software Foundation, Inc. * + * Copyright (C) 1992-2012, 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- * @@ -96,19 +96,7 @@ extern "C" { #define SHARED 'H' #define STATIC 'T' -#if defined (__osf__) -const char *__gnat_object_file_option = "-Wl,-input,"; -const char *__gnat_run_path_option = "-Wl,-rpath,"; -int __gnat_link_max = 10000; -unsigned char __gnat_objlist_file_supported = 1; -char __gnat_shared_libgnat_default = STATIC; -char __gnat_shared_libgcc_default = STATIC; -unsigned char __gnat_using_gnu_linker = 0; -const char *__gnat_object_library_extension = ".a"; -unsigned char __gnat_separate_run_path_options = 0; -const char *__gnat_default_libgcc_subdir = "lib"; - -#elif defined (sgi) +#if defined (sgi) const char *__gnat_object_file_option = "-Wl,-objectlist,"; const char *__gnat_run_path_option = "-Wl,-rpath,"; int __gnat_link_max = 5000; diff --git a/gcc/ada/memtrack.adb b/gcc/ada/memtrack.adb index 6b29e1748c3..ec490e21db9 100644 --- a/gcc/ada/memtrack.adb +++ b/gcc/ada/memtrack.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2012, 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- -- @@ -61,7 +61,6 @@ -- HP-UX -- Irix -- Solaris --- Tru64 -- Alpha OpenVMS -- NOTE FOR FUTURE PLATFORMS SUPPORT: It is assumed that type Duration is diff --git a/gcc/ada/mlib-tgt-specific-tru64.adb b/gcc/ada/mlib-tgt-specific-tru64.adb deleted file mode 100644 index b5f5a137122..00000000000 --- a/gcc/ada/mlib-tgt-specific-tru64.adb +++ /dev/null @@ -1,168 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M L I B . T G T . S P E C I F I C -- --- (Tru64 Version) -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2008, 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. 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 COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the 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 Tru64 version of the body - -with MLib.Fil; -with MLib.Utl; -with Opt; -with Output; use Output; - -package body MLib.Tgt.Specific is - - use MLib; - - -- Non default subprogram - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False); - - function Is_Archive_Ext (Ext : String) return Boolean; - - function PIC_Option return String; - - -- Local variables - - Expect_Unresolved : aliased String := "-Wl,-expect_unresolved,*"; - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Interfaces); - pragma Unreferenced (Symbol_Data); - pragma Unreferenced (Auto_Init); - -- Initialization is done through the constructor mechanism - - Lib_File : constant String := - "lib" & Fil.Append_To (Lib_Filename, DLL_Ext); - - Lib_Path : constant String := - Lib_Dir & Directory_Separator & Lib_File; - - Version_Arg : String_Access; - Symbolic_Link_Needed : Boolean := False; - - begin - if Opt.Verbose_Mode then - Write_Str ("building relocatable shared library "); - Write_Line (Lib_Path); - end if; - - -- If specified, add automatic elaboration/finalization - - if Lib_Version = "" then - Utl.Gcc - (Output_File => Lib_Path, - Objects => Ofiles, - Options => Options & Expect_Unresolved'Access, - Options_2 => No_Argument_List, - Driver_Name => Driver_Name); - - else - declare - Maj_Version : constant String := - Major_Id_Name (Lib_File, Lib_Version); - begin - if Maj_Version'Length /= 0 then - Version_Arg := new String'("-Wl,-soname," & Maj_Version); - - else - Version_Arg := new String'("-Wl,-soname," & Lib_Version); - end if; - - if Is_Absolute_Path (Lib_Version) then - Utl.Gcc - (Output_File => Lib_Version, - Objects => Ofiles, - Options => - Options & Version_Arg & Expect_Unresolved'Access, - Options_2 => No_Argument_List, - Driver_Name => Driver_Name); - Symbolic_Link_Needed := Lib_Version /= Lib_Path; - - else - Utl.Gcc - (Output_File => Lib_Dir & Directory_Separator & Lib_Version, - Objects => Ofiles, - Options => - Options & Version_Arg & Expect_Unresolved'Access, - Options_2 => No_Argument_List, - Driver_Name => Driver_Name); - Symbolic_Link_Needed := - Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path; - end if; - - if Symbolic_Link_Needed then - Create_Sym_Links - (Lib_Path, Lib_Version, Lib_Dir, Maj_Version); - end if; - end; - end if; - end Build_Dynamic_Library; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".a" or else Ext = ".so"; - end Is_Archive_Ext; - - ---------------- - -- PIC_Option -- - ---------------- - - function PIC_Option return String is - begin - return ""; - end PIC_Option; - -begin - Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; - Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; - PIC_Option_Ptr := PIC_Option'Access; -end MLib.Tgt.Specific; diff --git a/gcc/ada/s-mastop-tru64.adb b/gcc/ada/s-mastop-tru64.adb deleted file mode 100644 index 7114ea700f4..00000000000 --- a/gcc/ada/s-mastop-tru64.adb +++ /dev/null @@ -1,163 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- SYSTEM.MACHINE_STATE_OPERATIONS -- --- -- --- B o d y -- --- (Version for Alpha/Dec Unix) -- --- -- --- Copyright (C) 1999-2010, AdaCore -- --- -- --- 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 version of System.Machine_State_Operations is for use on --- Alpha systems running DEC Unix. - -with System.Memory; - -package body System.Machine_State_Operations is - - pragma Linker_Options ("-lexc"); - -- Needed for definitions of exc_capture_context and exc_virtual_unwind - - ---------------------------- - -- Allocate_Machine_State -- - ---------------------------- - - function Allocate_Machine_State return Machine_State is - use System.Storage_Elements; - - function c_machine_state_length return Storage_Offset; - pragma Import (C, c_machine_state_length, "__gnat_machine_state_length"); - - begin - return Machine_State - (Memory.Alloc (Memory.size_t (c_machine_state_length))); - end Allocate_Machine_State; - - ---------------- - -- Fetch_Code -- - ---------------- - - function Fetch_Code (Loc : Code_Loc) return Code_Loc is - begin - return Loc; - end Fetch_Code; - - ------------------------ - -- Free_Machine_State -- - ------------------------ - - procedure Free_Machine_State (M : in out Machine_State) is - begin - Memory.Free (Address (M)); - M := Machine_State (Null_Address); - end Free_Machine_State; - - ------------------ - -- Get_Code_Loc -- - ------------------ - - function Get_Code_Loc (M : Machine_State) return Code_Loc is - Asm_Call_Size : constant := 4; - - function c_get_code_loc (M : Machine_State) return Code_Loc; - pragma Import (C, c_get_code_loc, "__gnat_get_code_loc"); - - -- Code_Loc returned by c_get_code_loc is the return point but here we - -- want Get_Code_Loc to return the call point. Under DEC Unix a call - -- asm instruction takes 4 bytes. So we must remove this value from - -- c_get_code_loc to have the call point. - - Loc : constant Code_Loc := c_get_code_loc (M); - - begin - if Loc = 0 then - return 0; - else - return Loc - Asm_Call_Size; - end if; - end Get_Code_Loc; - - -------------------------- - -- Machine_State_Length -- - -------------------------- - - function Machine_State_Length - return System.Storage_Elements.Storage_Offset - is - use System.Storage_Elements; - - function c_machine_state_length return Storage_Offset; - pragma Import (C, c_machine_state_length, "__gnat_machine_state_length"); - - begin - return c_machine_state_length; - end Machine_State_Length; - - --------------- - -- Pop_Frame -- - --------------- - - procedure Pop_Frame (M : Machine_State) is - procedure exc_virtual_unwind (Fcn : System.Address; M : Machine_State); - pragma Import (C, exc_virtual_unwind, "exc_virtual_unwind"); - - function exc_lookup_function (Loc : Code_Loc) return System.Address; - pragma Import (C, exc_lookup_function, "exc_lookup_function_entry"); - - procedure c_set_code_loc (M : Machine_State; Loc : Code_Loc); - pragma Import (C, c_set_code_loc, "__gnat_set_code_loc"); - - -- Look for a code-range descriptor table containing the PC of the - -- specified machine state. If we don't find any, attempting to unwind - -- further would fail so we set the machine state's code location to a - -- value indicating that the top of the call chain is reached. This - -- happens when the function at the address pointed to by PC has not - -- been registered with the unwinding machinery, as with the __istart - -- functions generated by the linker in presence of initialization - -- routines for example. - - Prf : constant System.Address := exc_lookup_function (Get_Code_Loc (M)); - - begin - if Prf = System.Null_Address then - c_set_code_loc (M, 0); - else - exc_virtual_unwind (Prf, M); - end if; - end Pop_Frame; - - ----------------------- - -- Set_Machine_State -- - ----------------------- - - procedure Set_Machine_State (M : Machine_State) is - procedure c_capture_context (M : Machine_State); - pragma Import (C, c_capture_context, "exc_capture_context"); - begin - c_capture_context (M); - Pop_Frame (M); - end Set_Machine_State; - -end System.Machine_State_Operations; diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 340abe99fe8..3005ba781a0 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -7,7 +7,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2012, 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- -- @@ -85,12 +85,6 @@ pragma Style_Checks ("M32766"); **/ #define _XOPEN_SOURCE 500 -#elif defined (__alpha__) && defined (__osf__) -/** For Tru64 UNIX, _XOPEN_SOURCE must be defined, otherwise CLOCK_REALTIME - ** is not defined. - **/ -#define _XOPEN_SOURCE 500 - #elif defined (__mips) && defined (__sgi) /** For IRIX 6, _XOPEN5 must be defined and _XOPEN_IOV_MAX must be used as ** IOV_MAX, otherwise IOV_MAX is not defined. IRIX 5 has neither. @@ -111,14 +105,6 @@ pragma Style_Checks ("M32766"); #include <fcntl.h> #include <time.h> -#if defined (__alpha__) && defined (__osf__) -/** Tru64 is unable to do vector IO operations with default value of IOV_MAX, - ** so its value is redefined to a small one which is known to work properly. - **/ -#undef IOV_MAX -#define IOV_MAX 16 -#endif - #if defined (__VMS) /** VMS is unable to do vector IO operations with default value of IOV_MAX, ** so its value is redefined to a small one which is known to work properly. @@ -978,15 +964,6 @@ CND(AF_INET, "IPv4 address family") # undef AF_INET6 #endif -/** - ** Tru64 UNIX V4.0F defines AF_INET6 without IPv6 support, specifically - ** without struct sockaddr_in6. We use _SS_MAXSIZE (used for the definition - ** of struct sockaddr_storage on Tru64 UNIX V5.1) to detect this. - **/ -#if defined(__osf__) && !defined(_SS_MAXSIZE) -# undef AF_INET6 -#endif - #ifndef AF_INET6 # define AF_INET6 -1 #else diff --git a/gcc/ada/s-osinte-tru64.adb b/gcc/ada/s-osinte-tru64.adb deleted file mode 100644 index ad391bcb473..00000000000 --- a/gcc/ada/s-osinte-tru64.adb +++ /dev/null @@ -1,142 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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) 1998-2009, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 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 the DEC Unix 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; -with System.Machine_Code; use System.Machine_Code; - -package body System.OS_Interface is - - -------------------- - -- Get_Stack_Base -- - -------------------- - - function Get_Stack_Base (thread : pthread_t) return Address is - pragma Unreferenced (thread); - begin - return Null_Address; - end Get_Stack_Base; - - ------------------ - -- pthread_init -- - ------------------ - - procedure pthread_init is - begin - null; - end pthread_init; - - ------------------ - -- pthread_self -- - ------------------ - - function pthread_self return pthread_t is - Self : pthread_t; - begin - Asm ("call_pal 0x9e" & ASCII.LF & ASCII.HT & - "bis $31, $0, %0", - Outputs => pthread_t'Asm_Output ("=r", Self), - Clobber => "$0", - Volatile => True); - return Self; - end pthread_self; - - ---------------------- - -- Hide_Yellow_Zone -- - ---------------------- - - procedure Hide_Unhide_Yellow_Zone (Hide : Boolean) is - type Teb_Ptr is access all pthread_teb_t; - Teb : Teb_Ptr; - Res : Interfaces.C.int; - pragma Unreferenced (Res); - - begin - -- Get the Thread Environment Block address - - Asm ("call_pal 0x9e" & ASCII.LF & ASCII.HT & - "bis $31, $0, %0", - Outputs => Teb_Ptr'Asm_Output ("=r", Teb), - Clobber => "$0", - Volatile => True); - - -- Stick a guard page right above the Yellow Zone if it exists - - if Teb.all.stack_yellow /= Teb.all.stack_guard then - Res := - mprotect - (Teb.all.stack_yellow, Get_Page_Size, - prot => (if Hide then PROT_ON else PROT_OFF)); - end if; - end Hide_Unhide_Yellow_Zone; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (TS : timespec) return Duration is - begin - return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; - end To_Duration; - - ----------------- - -- To_Timespec -- - ----------------- - - function To_Timespec (D : Duration) return timespec is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return timespec'(tv_sec => S, - tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); - end To_Timespec; - -end System.OS_Interface; diff --git a/gcc/ada/s-osinte-tru64.ads b/gcc/ada/s-osinte-tru64.ads deleted file mode 100644 index 0fcd4221e80..00000000000 --- a/gcc/ada/s-osinte-tru64.ads +++ /dev/null @@ -1,585 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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-2011, 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 the Tru64 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; - -package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("-lpthread"); - pragma Linker_Options ("-lmach"); - pragma Linker_Options ("-lexc"); - pragma Linker_Options ("-lrt"); - - 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; - subtype char_array is Interfaces.C.char_array; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "_Geterrno"); - - EAGAIN : constant := 35; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - ETIMEDOUT : constant := 60; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 48; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGIOT : constant := 6; -- abort (terminate) process - SIGLOST : constant := 6; -- old BSD signal ?? - SIGEMT : constant := 7; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad argument to system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGURG : constant := 16; -- urgent condition on IO channel - SIGIOINT : constant := 16; -- printer to backend error signal - SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 18; -- user stop requested from tty - SIGCONT : constant := 19; -- stopped process has been continued - SIGCHLD : constant := 20; -- child status change - SIGTTIN : constant := 21; -- background tty read attempted - SIGTTOU : constant := 22; -- background tty write attempted - SIGPOLL : constant := 23; -- I/O possible, or completed - SIGIO : constant := 23; -- STREAMS version of SIGPOLL - SIGAIO : constant := 23; -- base lan i/o - SIGPTY : constant := 23; -- pty i/o - SIGXCPU : constant := 24; -- CPU time limit exceeded - SIGXFSZ : constant := 25; -- filesize limit exceeded - SIGVTALRM : constant := 26; -- virtual timer expired - SIGPROF : constant := 27; -- profiling timer expired - SIGWINCH : constant := 28; -- window size change - SIGINFO : constant := 29; -- information request - SIGPWR : constant := 29; -- Power Fail/Restart -- SVID3/SVR4 - SIGUSR1 : constant := 30; -- user defined signal 1 - SIGUSR2 : constant := 31; -- user defined signal 2 - SIGRESV : constant := 32; -- reserved by Digital for future use - - SIGADAABORT : constant := SIGABRT; - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := (0 .. 0 => SIGTRAP); - Reserved : constant Signal_Set := (SIGALRM, SIGABRT, SIGKILL, SIGSTOP); - - type sigset_t is private; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset); - - type union_type_3 is new String (1 .. 116); - type siginfo_t is record - si_signo : int; - si_errno : int; - si_code : int; - X_data : union_type_3; - end record; - for siginfo_t'Size use 8 * 128; - pragma Convention (C, siginfo_t); - - type struct_sigaction is record - sa_handler : System.Address; - sa_mask : sigset_t; - sa_flags : int; - sa_signo : int; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - SIG_BLOCK : constant := 1; - SIG_UNBLOCK : constant := 2; - SIG_SETMASK : constant := 3; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - SA_NODEFER : constant := 8; - SA_SIGINFO : constant := 16#40#; - SA_ONSTACK : constant := 16#01#; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction); - - ---------- - -- Time -- - ---------- - - type timespec is private; - - function nanosleep (rqtp, rmtp : access timespec) return int; - pragma Import (C, nanosleep); - - type clockid_t is new int; - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) return int; - pragma Import (C, clock_gettime); - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timezone is record - tz_minuteswest : int; - tz_dsttime : int; - end record; - pragma Convention (C, struct_timezone); - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 1; - SCHED_RR : constant := 2; - SCHED_OTHER : constant := 3; - SCHED_LFI : constant := 5; - - ------------- - -- 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); - - BIND_NO_INHERIT : constant := 1; - - function bind_to_cpu - (pid : pid_t; - cpu_mask : unsigned_long; - flag : unsigned_long := BIND_NO_INHERIT) return int; - pragma Import (C, bind_to_cpu); - - ------------- - -- 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.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_DETACHED : constant := 1; - - PTHREAD_SCOPE_PROCESS : constant := 0; - PTHREAD_SCOPE_SYSTEM : constant := 1; - - PTHREAD_EXPLICIT_SCHED : constant := 1; - - ----------- - -- Stack -- - ----------- - - Stack_Base_Available : constant Boolean := False; - -- Indicates if the stack base is available on this target - - function Get_Stack_Base (thread : pthread_t) return Address; - pragma Inline (Get_Stack_Base); - -- Returns the stack base of the specified thread. Only call this function - -- when Stack_Base_Available is True. - - function Get_Page_Size return size_t; - function Get_Page_Size return Address; - pragma Import (C, Get_Page_Size, "getpagesize"); - -- Returns the size of a page - - PROT_NONE : constant := 0; - PROT_READ : constant := 1; - PROT_WRITE : constant := 2; - PROT_EXEC : constant := 4; - PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; - - PROT_ON : constant := PROT_READ; - PROT_OFF : constant := PROT_ALL; - - function mprotect (addr : Address; len : size_t; prot : int) return int; - pragma Import (C, mprotect); - - procedure Hide_Unhide_Yellow_Zone (Hide : Boolean); - -- Every thread except the initial one features an overflow warning area - -- (called the Yellow Zone) which is just above the overflow guard area - -- on the stack (called the Red Zone). During task execution, we want - -- signals from the Red Zone, so we need to hide the Yellow Zone. This - -- procedure is called at the start of task execution (with Hide set True) - -- to hide the Yellow Zone, and at the end of task execution (with Hide - -- set False) to unhide the Yellow Zone. - - --------------------------------------- - -- Nonstandard Thread Initialization -- - --------------------------------------- - - procedure pthread_init; - pragma Inline (pthread_init); - -- This is a dummy procedure to share some GNULLI files - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait - (set : access sigset_t; - sig : access Signal) return int; - pragma Import (C, sigwait, "__sigwaitd10"); - - function pthread_kill - (thread : pthread_t; - sig : Signal) return int; - pragma Import (C, pthread_kill); - - function pthread_sigmask - (how : int; - set : access sigset_t; - oset : access sigset_t) return int; - pragma Import (C, pthread_sigmask); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init (attr : access pthread_mutexattr_t) - return int; - pragma Import (C, pthread_mutexattr_init); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy); - - 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); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, 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_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_cond_wait, "__pthread_cond_wait"); - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - pragma Import (C, pthread_cond_timedwait, "__pthread_cond_timedwait"); - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; - protocol : int) return int; - pragma Import (C, pthread_mutexattr_setprotocol); - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) return int; - pragma Import (C, pthread_mutexattr_setprioceiling); - - type struct_sched_param is record - sched_priority : int; -- scheduling priority - end record; - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - pragma Import (C, pthread_setschedparam); - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - pragma Import (C, 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); - - function pthread_attr_setschedparam - (attr : access pthread_attr_t; - sched_param : access struct_sched_param) return int; - pragma Import (C, pthread_attr_setschedparam); - - function sched_yield return int; - pragma Import (C, sched_yield); - - -------------------------- - -- P1003.1c Section 16 -- - -------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) - return int; - pragma Import (C, pthread_attr_init); - - function pthread_attr_destroy (attributes : access pthread_attr_t) - return int; - pragma Import (C, pthread_attr_destroy); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - pragma Import (C, 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 Inline (pthread_self); - - -------------------------- - -- 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); - -private - - type sigset_t is new unsigned_long; - - type pid_t is new int; - - type time_t is new int; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type unsigned_long_array is array (Natural range <>) of unsigned_long; - - type pthread_t is new System.Address; - - type pthread_teb_t is record - reserved1 : System.Address; - reserved2 : System.Address; - size : unsigned_short; - version : unsigned_char; - reserved3 : unsigned_char; - external : unsigned_char; - reserved4 : char_array (0 .. 1); - creator : unsigned_char; - sequence : unsigned_long; - reserved5 : unsigned_long_array (0 .. 1); - per_kt_area : System.Address; - stack_base : System.Address; - stack_reserve : System.Address; - stack_yellow : System.Address; - stack_guard : System.Address; - stack_size : unsigned_long; - tsd_values : System.Address; - tsd_count : unsigned_long; - reserved6 : unsigned; - reserved7 : unsigned; - thread_flags : unsigned; - thd_errno : int; - stack_hiwater : System.Address; - home_rad : unsigned_long; - end record; - pragma Convention (C, pthread_teb_t); - - type pthread_cond_t is record - state : unsigned; - valid : unsigned; - name : System.Address; - arg : unsigned; - reserved1 : unsigned; - sequence : unsigned_long; - block : System.Address; - end record; - pragma Convention (C, pthread_cond_t); - - type pthread_attr_t is record - valid : long; - name : System.Address; - arg : unsigned_long; - reserved : unsigned_long_array (0 .. 18); - end record; - pragma Convention (C, pthread_attr_t); - - type pthread_mutex_t is record - lock : unsigned; - valid : unsigned; - name : System.Address; - arg : unsigned; - depth : unsigned; - sequence : unsigned_long; - owner : unsigned_long; - block : System.Address; - end record; - for pthread_mutex_t'Size use 8 * 48; - pragma Convention (C, pthread_mutex_t); - - type pthread_mutexattr_t is record - valid : long; - reserved : unsigned_long_array (0 .. 14); - end record; - pragma Convention (C, pthread_mutexattr_t); - - type pthread_condattr_t is record - valid : long; - reserved : unsigned_long_array (0 .. 12); - end record; - pragma Convention (C, pthread_condattr_t); - - type pthread_key_t is new unsigned; - -end System.OS_Interface; diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb deleted file mode 100644 index 8d69e5b19b1..00000000000 --- a/gcc/ada/s-taprop-tru64.adb +++ /dev/null @@ -1,1365 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 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 Tru64 version of this package - --- This package contains all the GNULL primitives that interface directly with --- the underlying OS. - -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; -with Interfaces.C; - -with System.Tasking.Debug; -with System.Interrupt_Management; -with System.OS_Constants; -with System.OS_Primitives; -with System.Task_Info; - -with System.Soft_Links; --- We use System.Soft_Links instead of System.Tasking.Initialization --- because the later is a higher level package that we shouldn't depend on. --- For example when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Stages. - -package body System.Task_Primitives.Operations is - - package OSC renames System.OS_Constants; - package SSL renames System.Soft_Links; - - use System.Tasking.Debug; - use System.Tasking; - use Interfaces.C; - use System.OS_Interface; - use System.Parameters; - use System.OS_Primitives; - - ---------------- - -- Local Data -- - ---------------- - - -- The followings are logically constants, but need to be initialized - -- at run time. - - Single_RTS_Lock : aliased RTS_Lock; - -- This is a lock to allow only one thread of control in the RTS at - -- a time; it is used to execute in mutual exclusion from all other tasks. - -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - - Environment_Task_Id : Task_Id; - -- A variable to hold Task_Id for the environment task - - Unblocked_Signal_Mask : aliased sigset_t; - -- The set of signals that should unblocked in all tasks - - Time_Slice_Val : Integer; - pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - - Locking_Policy : Character; - pragma Import (C, Locking_Policy, "__gl_locking_policy"); - - Dispatching_Policy : Character; - pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - - Curpid : pid_t; - - Foreign_Task_Elaborated : aliased Boolean := True; - -- Used to identified fake tasks (i.e., non-Ada Threads) - - Abort_Handler_Installed : Boolean := False; - -- True if a handler for the abort signal is installed - - -------------------- - -- Local Packages -- - -------------------- - - package Specific is - - procedure Initialize (Environment_Task : Task_Id); - pragma Inline (Initialize); - -- Initialize various data needed by this package - - function Is_Valid_Task return Boolean; - pragma Inline (Is_Valid_Task); - -- Does executing thread have a TCB? - - procedure Set (Self_Id : Task_Id); - pragma Inline (Set); - -- Set the self id for the current task - - function Self return Task_Id; - pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task - - end Specific; - - package body Specific is separate; - -- The body of this package is target specific - - ---------------------------------- - -- ATCB allocation/deallocation -- - ---------------------------------- - - package body ATCB_Allocation is separate; - -- The body of this package is shared across several targets - - --------------------------------- - -- Support for foreign threads -- - --------------------------------- - - function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; - -- Allocate and initialize a new ATCB for the current Thread - - function Register_Foreign_Thread - (Thread : Thread_Id) return Task_Id is separate; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Abort_Handler (Sig : Signal); - -- Signal handler used to implement asynchronous abort - - function Get_Policy (Prio : System.Any_Priority) return Character; - pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); - -- Get priority specific dispatching policy - - ------------------- - -- Abort_Handler -- - ------------------- - - procedure Abort_Handler (Sig : Signal) is - pragma Unreferenced (Sig); - - T : constant Task_Id := Self; - Old_Set : aliased sigset_t; - - Result : Interfaces.C.int; - pragma Warnings (Off, Result); - - begin - -- It's not safe to raise an exception when using GCC ZCX mechanism. - -- Note that we still need to install a signal handler, since in some - -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we - -- need to send the Abort signal to a task. - - if ZCX_By_Default then - return; - end if; - - if T.Deferral_Level = 0 - and then T.Pending_ATC_Level < T.ATC_Nesting_Level - and then not T.Aborting - then - T.Aborting := True; - - -- Make sure signals used for RTS internal purpose are unmasked - - Result := - pthread_sigmask - (SIG_UNBLOCK, - Unblocked_Signal_Mask'Access, - Old_Set'Access); - pragma Assert (Result = 0); - - raise Standard'Abort_Signal; - end if; - end Abort_Handler; - - ------------------ - -- Stack_Guard -- - ------------------ - - -- The underlying thread system sets a guard page at the bottom of a thread - -- stack, so nothing is needed. - - procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is - pragma Unreferenced (T); - pragma Unreferenced (On); - begin - null; - end Stack_Guard; - - -------------------- - -- Get_Thread_Id -- - -------------------- - - function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is - begin - return T.Common.LL.Thread; - end Get_Thread_Id; - - ---------- - -- Self -- - ---------- - - function Self return Task_Id renames Specific.Self; - - --------------------- - -- Initialize_Lock -- - --------------------- - - -- Note: mutexes and cond_variables needed per-task basis are initialized - -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such - -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any - -- status change of RTS. Therefore raising Storage_Error in the following - -- routines should be able to be handled safely. - - procedure Initialize_Lock - (Prio : System.Any_Priority; - L : not null access Lock) - is - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - if Locking_Policy = 'C' then - L.Ceiling := Interfaces.C.int (Prio); - end if; - - Result := pthread_mutex_init (L.L'Access, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Attributes'Access); - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - procedure Initialize_Lock - (L : not null access RTS_Lock; - Level : Lock_Level) - is - pragma Unreferenced (Level); - - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutex_init (L, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Attributes'Access); - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - ------------------- - -- Finalize_Lock -- - ------------------- - - procedure Finalize_Lock (L : not null access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L.L'Access); - pragma Assert (Result = 0); - end Finalize_Lock; - - procedure Finalize_Lock (L : not null access RTS_Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L); - pragma Assert (Result = 0); - end Finalize_Lock; - - ---------------- - -- Write_Lock -- - ---------------- - - procedure Write_Lock - (L : not null access Lock; - Ceiling_Violation : out Boolean) - is - Result : Interfaces.C.int; - Self_ID : Task_Id; - All_Tasks_Link : Task_Id; - Current_Prio : System.Any_Priority; - - begin - -- Perform ceiling checks only when this is the locking policy in use - - if Locking_Policy = 'C' then - Self_ID := Self; - All_Tasks_Link := Self_ID.Common.All_Tasks_Link; - Current_Prio := Get_Priority (Self_ID); - - -- If there is no other task, no need to check priorities - - if All_Tasks_Link /= Null_Task - and then L.Ceiling < Interfaces.C.int (Current_Prio) - then - Ceiling_Violation := True; - return; - end if; - end if; - - Result := pthread_mutex_lock (L.L'Access); - pragma Assert (Result = 0); - - Ceiling_Violation := False; - end Write_Lock; - - procedure Write_Lock - (L : not null access RTS_Lock; - Global_Lock : Boolean := False) - is - Result : Interfaces.C.int; - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_lock (L); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - procedure Write_Lock (T : Task_Id) is - Result : Interfaces.C.int; - begin - if not Single_Lock then - Result := pthread_mutex_lock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock - (L : not null access Lock; - Ceiling_Violation : out Boolean) - is - begin - Write_Lock (L, Ceiling_Violation); - end Read_Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (L : not null access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_unlock (L.L'Access); - pragma Assert (Result = 0); - end Unlock; - - procedure Unlock - (L : not null access RTS_Lock; - Global_Lock : Boolean := False) - is - Result : Interfaces.C.int; - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0); - end if; - end Unlock; - - procedure Unlock (T : Task_Id) is - Result : Interfaces.C.int; - begin - if not Single_Lock then - Result := pthread_mutex_unlock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Unlock; - - ----------------- - -- Set_Ceiling -- - ----------------- - - -- Dynamic priority ceilings are not supported by the underlying system - - procedure Set_Ceiling - (L : not null access Lock; - Prio : System.Any_Priority) - is - pragma Unreferenced (L, Prio); - begin - null; - end Set_Ceiling; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep - (Self_ID : Task_Id; - Reason : System.Tasking.Task_States) - is - pragma Unreferenced (Reason); - - Result : Interfaces.C.int; - - begin - Result := - pthread_cond_wait - (cond => Self_ID.Common.LL.CV'Access, - mutex => (if Single_Lock - then Single_RTS_Lock'Access - else Self_ID.Common.LL.L'Access)); - - -- EINTR is not considered a failure - - pragma Assert (Result = 0 or else Result = EINTR); - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - -- This is for use within the run-time system, so abort is assumed to be - -- already deferred, and the caller should be holding its own ATCB lock. - - procedure Timed_Sleep - (Self_ID : Task_Id; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : System.Tasking.Task_States; - Timedout : out Boolean; - Yielded : out Boolean) - is - pragma Unreferenced (Reason); - - Base_Time : constant Duration := Monotonic_Clock; - Check_Time : Duration := Base_Time; - Abs_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - - begin - Timedout := True; - Yielded := False; - - Abs_Time := - (if Mode = Relative - then Duration'Min (Time, Max_Sensible_Delay) + Check_Time - else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); - - if Abs_Time > Check_Time then - Request := To_Timespec (Abs_Time); - - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - Result := - pthread_cond_timedwait - (cond => Self_ID.Common.LL.CV'Access, - mutex => (if Single_Lock - then Single_RTS_Lock'Access - else Self_ID.Common.LL.L'Access), - abstime => Request'Access); - - Check_Time := Monotonic_Clock; - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - if Result = 0 or Result = EINTR then - - -- Somebody may have called Wakeup for us - - Timedout := False; - exit; - end if; - - pragma Assert (Result = ETIMEDOUT); - end loop; - end if; - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - -- This is for use in implementing delay statements, so we assume the - -- caller is abort-deferred but is holding no locks. - - procedure Timed_Delay - (Self_ID : Task_Id; - Time : Duration; - Mode : ST.Delay_Modes) - is - Base_Time : constant Duration := Monotonic_Clock; - Check_Time : Duration := Base_Time; - Abs_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - - begin - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_ID); - - Abs_Time := - (if Mode = Relative - then Time + Check_Time - else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); - - if Abs_Time > Check_Time then - Request := To_Timespec (Abs_Time); - Self_ID.Common.State := Delay_Sleep; - - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - Result := - pthread_cond_timedwait - (cond => Self_ID.Common.LL.CV'Access, - mutex => (if Single_Lock - then Single_RTS_Lock'Access - else Self_ID.Common.LL.L'Access), - abstime => Request'Access); - - Check_Time := Monotonic_Clock; - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - pragma Assert (Result = 0 or else - Result = ETIMEDOUT or else - Result = EINTR); - end loop; - - Self_ID.Common.State := Runnable; - end if; - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - Yield; - end Timed_Delay; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration is - TS : aliased timespec; - Result : Interfaces.C.int; - begin - Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); - pragma Assert (Result = 0); - return To_Duration (TS); - end Monotonic_Clock; - - ------------------- - -- RT_Resolution -- - ------------------- - - function RT_Resolution return Duration is - begin - -- Returned value must be an integral multiple of Duration'Small (1 ns) - -- The following is the best approximation of 1/1024. The clock on the - -- DEC Alpha ticks at 1024 Hz. - - return 0.000_976_563; - end RT_Resolution; - - ------------ - -- Wakeup -- - ------------ - - procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is - pragma Unreferenced (Reason); - Result : Interfaces.C.int; - begin - Result := pthread_cond_signal (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Wakeup; - - ----------- - -- Yield -- - ----------- - - procedure Yield (Do_Yield : Boolean := True) is - Result : Interfaces.C.int; - pragma Unreferenced (Result); - begin - if Do_Yield then - Result := sched_yield; - end if; - end Yield; - - ------------------ - -- Set_Priority -- - ------------------ - - procedure Set_Priority - (T : Task_Id; - Prio : System.Any_Priority; - Loss_Of_Inheritance : Boolean := False) - is - pragma Unreferenced (Loss_Of_Inheritance); - - Result : Interfaces.C.int; - Param : aliased struct_sched_param; - - Priority_Specific_Policy : constant Character := Get_Policy (Prio); - -- Upper case first character of the policy name corresponding to the - -- task as set by a Priority_Specific_Dispatching pragma. - - begin - T.Common.Current_Priority := Prio; - Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); - - if Dispatching_Policy = 'R' - or else Priority_Specific_Policy = 'R' - or else Time_Slice_Val > 0 - then - Result := - pthread_setschedparam - (T.Common.LL.Thread, SCHED_RR, Param'Access); - - elsif Dispatching_Policy = 'F' - or else Priority_Specific_Policy = 'F' - or else Time_Slice_Val = 0 - then - Result := - pthread_setschedparam - (T.Common.LL.Thread, SCHED_FIFO, Param'Access); - - else - Result := - pthread_setschedparam - (T.Common.LL.Thread, SCHED_OTHER, Param'Access); - end if; - - pragma Assert (Result = 0); - end Set_Priority; - - ------------------ - -- Get_Priority -- - ------------------ - - function Get_Priority (T : Task_Id) return System.Any_Priority is - begin - return T.Common.Current_Priority; - end Get_Priority; - - ---------------- - -- Enter_Task -- - ---------------- - - procedure Enter_Task (Self_ID : Task_Id) is - begin - Hide_Unhide_Yellow_Zone (Hide => True); - Self_ID.Common.LL.Thread := pthread_self; - - Specific.Set (Self_ID); - end Enter_Task; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - function Register_Foreign_Thread return Task_Id is - begin - if Is_Valid_Task then - return Self; - else - return Register_Foreign_Thread (pthread_self); - end if; - end Register_Foreign_Thread; - - -------------------- - -- Initialize_TCB -- - -------------------- - - procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is - Mutex_Attr : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - Cond_Attr : aliased pthread_condattr_t; - - begin - if not Single_Lock then - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := - pthread_mutex_init - (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := - pthread_cond_init - (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result = 0 then - Succeeded := True; - else - if not Single_Lock then - Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Succeeded := False; - end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - end Initialize_TCB; - - ----------------- - -- Create_Task -- - ----------------- - - procedure Create_Task - (T : Task_Id; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean) - is - Attributes : aliased pthread_attr_t; - Adjusted_Stack_Size : Interfaces.C.size_t; - Result : Interfaces.C.int; - Param : aliased System.OS_Interface.struct_sched_param; - - Priority_Specific_Policy : constant Character := Get_Policy (Priority); - -- Upper case first character of the policy name corresponding to the - -- task as set by a Priority_Specific_Dispatching pragma. - - use System.Task_Info; - - begin - -- Account for the Yellow Zone (2 pages) and the guard page right above. - -- See Hide_Unhide_Yellow_Zone for the rationale. - - Adjusted_Stack_Size := - Interfaces.C.size_t (Stack_Size) + 3 * Get_Page_Size; - - Result := pthread_attr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := - pthread_attr_setdetachstate - (Attributes'Access, PTHREAD_CREATE_DETACHED); - pragma Assert (Result = 0); - - Result := - pthread_attr_setstacksize - (Attributes'Access, Adjusted_Stack_Size); - pragma Assert (Result = 0); - - Param.sched_priority := - Interfaces.C.int (Underlying_Priorities (Priority)); - Result := - pthread_attr_setschedparam - (Attributes'Access, Param'Access); - pragma Assert (Result = 0); - - if Dispatching_Policy = 'R' - or else Priority_Specific_Policy = 'R' - or else Time_Slice_Val > 0 - then - Result := - pthread_attr_setschedpolicy - (Attributes'Access, System.OS_Interface.SCHED_RR); - - elsif Dispatching_Policy = 'F' - or else Priority_Specific_Policy = 'F' - or else Time_Slice_Val = 0 - then - Result := - pthread_attr_setschedpolicy - (Attributes'Access, System.OS_Interface.SCHED_FIFO); - - else - Result := - pthread_attr_setschedpolicy - (Attributes'Access, System.OS_Interface.SCHED_OTHER); - end if; - - pragma Assert (Result = 0); - - -- Set the scheduling parameters explicitly, since this is the only way - -- to force the OS to take e.g. the sched policy and scope attributes - -- into account. - - Result := - pthread_attr_setinheritsched - (Attributes'Access, PTHREAD_EXPLICIT_SCHED); - pragma Assert (Result = 0); - - T.Common.Current_Priority := Priority; - - if T.Common.Task_Info /= null then - case T.Common.Task_Info.Contention_Scope is - when System.Task_Info.Process_Scope => - Result := - pthread_attr_setscope - (Attributes'Access, PTHREAD_SCOPE_PROCESS); - - when System.Task_Info.System_Scope => - Result := - pthread_attr_setscope - (Attributes'Access, PTHREAD_SCOPE_SYSTEM); - - when System.Task_Info.Default_Scope => - Result := 0; - end case; - - pragma Assert (Result = 0); - end if; - - -- Since the initial signal mask of a thread is inherited from the - -- creator, and the Environment task has all its signals masked, we - -- do not need to manipulate caller's signal mask at this point. - -- All tasks in RTS will have All_Tasks_Mask initially. - - -- Note: the use of Unrestricted_Access in the following call is needed - -- because otherwise we have an error of getting a access-to-volatile - -- value which points to a non-volatile object. But in this case it is - -- safe to do this, since we know we have no problems with aliasing and - -- Unrestricted_Access bypasses this check. - - Result := - pthread_create - (T.Common.LL.Thread'Unrestricted_Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); - pragma Assert (Result = 0 or else Result = EAGAIN); - - Succeeded := Result = 0; - - Result := pthread_attr_destroy (Attributes'Access); - pragma Assert (Result = 0); - - if Succeeded and then T.Common.Task_Info /= null then - - -- ??? We're using a process-wide function to implement a task - -- specific characteristic. - - if T.Common.Task_Info.Bind_To_Cpu_Number = 0 then - Result := bind_to_cpu (Curpid, 0); - - elsif T.Common.Task_Info.Bind_To_Cpu_Number > 0 then - Result := - bind_to_cpu - (Curpid, - Interfaces.C.unsigned_long ( - Interfaces.Shift_Left - (Interfaces.Unsigned_64'(1), - T.Common.Task_Info.Bind_To_Cpu_Number - 1))); - pragma Assert (Result = 0); - end if; - end if; - end Create_Task; - - ------------------ - -- Finalize_TCB -- - ------------------ - - procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - - begin - if not Single_Lock then - Result := pthread_mutex_destroy (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_cond_destroy (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - - if T.Known_Tasks_Index /= -1 then - Known_Tasks (T.Known_Tasks_Index) := null; - end if; - - ATCB_Allocation.Free_ATCB (T); - end Finalize_TCB; - - --------------- - -- Exit_Task -- - --------------- - - procedure Exit_Task is - begin - Specific.Set (null); - Hide_Unhide_Yellow_Zone (Hide => False); - end Exit_Task; - - ---------------- - -- Abort_Task -- - ---------------- - - procedure Abort_Task (T : Task_Id) is - Result : Interfaces.C.int; - begin - if Abort_Handler_Installed then - Result := pthread_kill (T.Common.LL.Thread, - Signal (System.Interrupt_Management.Abort_Task_Interrupt)); - pragma Assert (Result = 0); - end if; - end Abort_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (S : in out Suspension_Object) is - Mutex_Attr : aliased pthread_mutexattr_t; - Cond_Attr : aliased pthread_condattr_t; - Result : Interfaces.C.int; - - begin - -- Initialize internal state (always to False (RM D.10(6))) - - S.State := False; - S.Waiting := False; - - -- Initialize internal mutex - - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - - -- Initialize internal condition variable - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); - - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - if Result = ENOMEM then - raise Storage_Error; - end if; - end if; - end Initialize; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - -- Destroy internal mutex - - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - -- Destroy internal condition variable - - Result := pthread_cond_destroy (S.CV'Access); - pragma Assert (Result = 0); - end Finalize; - - ------------------- - -- Current_State -- - ------------------- - - function Current_State (S : Suspension_Object) return Boolean is - begin - -- We do not want to use lock on this read operation. State is marked - -- as Atomic so that we ensure that the value retrieved is correct. - - return S.State; - end Current_State; - - --------------- - -- Set_False -- - --------------- - - procedure Set_False (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - S.State := False; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end Set_False; - - -------------- - -- Set_True -- - -------------- - - procedure Set_True (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - -- If there is already a task waiting on this suspension object then we - -- resume it, leaving the state of the suspension object to False, as - -- specified in (RM D.10(9)). Otherwise, leave the state set to True. - - if S.Waiting then - S.Waiting := False; - S.State := False; - - Result := pthread_cond_signal (S.CV'Access); - pragma Assert (Result = 0); - - else - S.State := True; - end if; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end Set_True; - - ------------------------ - -- Suspend_Until_True -- - ------------------------ - - procedure Suspend_Until_True (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - if S.Waiting then - - -- Program_Error must be raised upon calling Suspend_Until_True - -- if another task is already waiting on that suspension object - -- (AM D.10(10)). - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - - raise Program_Error; - - else - -- Suspend the task if the state is False. Otherwise, the task - -- continues its execution, and the state of the suspension object - -- is set to False (RM D.10(9)). - - if S.State then - S.State := False; - else - S.Waiting := True; - - loop - -- Loop in case pthread_cond_wait returns earlier than expected - -- (e.g. in case of EINTR caused by a signal). - - Result := pthread_cond_wait (S.CV'Access, S.L'Access); - pragma Assert (Result = 0 or else Result = EINTR); - - exit when not S.Waiting; - end loop; - end if; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end if; - end Suspend_Until_True; - - ---------------- - -- Check_Exit -- - ---------------- - - -- Dummy version - - function Check_Exit (Self_ID : ST.Task_Id) return Boolean is - pragma Unreferenced (Self_ID); - begin - return True; - end Check_Exit; - - -------------------- - -- Check_No_Locks -- - -------------------- - - function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is - pragma Unreferenced (Self_ID); - begin - return True; - end Check_No_Locks; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_Id is - begin - return Environment_Task_Id; - end Environment_Task; - - -------------- - -- Lock_RTS -- - -------------- - - procedure Lock_RTS is - begin - Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access, Global_Lock => True); - end Unlock_RTS; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_Id; - Thread_Self : Thread_Id) return Boolean - is - pragma Unreferenced (T, Thread_Self); - begin - return False; - end Suspend_Task; - - ----------------- - -- Resume_Task -- - ----------------- - - function Resume_Task - (T : ST.Task_Id; - Thread_Self : Thread_Id) return Boolean - is - pragma Unreferenced (T, Thread_Self); - begin - return False; - end Resume_Task; - - -------------------- - -- Stop_All_Tasks -- - -------------------- - - procedure Stop_All_Tasks is - begin - null; - end Stop_All_Tasks; - - --------------- - -- Stop_Task -- - --------------- - - function Stop_Task (T : ST.Task_Id) return Boolean is - pragma Unreferenced (T); - begin - return False; - end Stop_Task; - - ------------------- - -- Continue_Task -- - ------------------- - - function Continue_Task (T : ST.Task_Id) return Boolean is - pragma Unreferenced (T); - begin - return False; - end Continue_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_Id) is - act : aliased struct_sigaction; - old_act : aliased struct_sigaction; - Tmp_Set : aliased sigset_t; - Result : Interfaces.C.int; - - function State - (Int : System.Interrupt_Management.Interrupt_ID) return Character; - pragma Import (C, State, "__gnat_get_interrupt_state"); - -- Get interrupt state. Defined in a-init.c. The input argument is - -- the interrupt number, and the result is one of the following: - - Default : constant Character := 's'; - -- 'n' this interrupt not set by any Interrupt_State pragma - -- 'u' Interrupt_State pragma set state to User - -- 'r' Interrupt_State pragma set state to Runtime - -- 's' Interrupt_State pragma set state to System (use "default" - -- system handler) - - begin - Environment_Task_Id := Environment_Task; - - Interrupt_Management.Initialize; - - -- Prepare the set of signals that should unblocked in all tasks - - Result := sigemptyset (Unblocked_Signal_Mask'Access); - pragma Assert (Result = 0); - - for J in Interrupt_Management.Interrupt_ID loop - if System.Interrupt_Management.Keep_Unmasked (J) then - Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); - pragma Assert (Result = 0); - end if; - end loop; - - Curpid := getpid; - - -- Initialize the lock used to synchronize chain of all ATCBs - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); - - Specific.Initialize (Environment_Task); - - -- Make environment task known here because it doesn't go through - -- Activate_Tasks, which does it for all other tasks. - - Known_Tasks (Known_Tasks'First) := Environment_Task; - Environment_Task.Known_Tasks_Index := Known_Tasks'First; - - Enter_Task (Environment_Task); - - if State - (System.Interrupt_Management.Abort_Task_Interrupt) /= Default - then - act.sa_flags := 0; - act.sa_handler := Abort_Handler'Address; - - Result := sigemptyset (Tmp_Set'Access); - pragma Assert (Result = 0); - act.sa_mask := Tmp_Set; - - Result := - sigaction - (Signal (System.Interrupt_Management.Abort_Task_Interrupt), - act'Unchecked_Access, - old_act'Unchecked_Access); - pragma Assert (Result = 0); - Abort_Handler_Installed := True; - end if; - end Initialize; - - ----------------------- - -- Set_Task_Affinity -- - ----------------------- - - procedure Set_Task_Affinity (T : ST.Task_Id) is - pragma Unreferenced (T); - - begin - -- Setting task affinity is not supported by the underlying system - - null; - end Set_Task_Affinity; -end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-tasinf-tru64.ads b/gcc/ada/s-tasinf-tru64.ads deleted file mode 100644 index af2832d09e1..00000000000 --- a/gcc/ada/s-tasinf-tru64.ads +++ /dev/null @@ -1,110 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T A S K _ I N F O -- --- -- --- S p e c -- --- (Compiler Interface) -- --- -- --- Copyright (C) 1998-2009, 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 contains the definitions and routines associated with the --- implementation and use of the Task_Info pragma. It is specialized --- appropriately for targets that make use of this pragma. - --- Note: the compiler generates direct calls to this interface, via Rtsfind. --- Any changes to this interface may require corresponding compiler changes. - --- This unit may be used directly from an application program by providing --- an appropriate WITH, and the interface can be expected to remain stable. - --- This is a DEC Unix 4.0d version of this package - -package System.Task_Info is - pragma Preelaborate; - pragma Elaborate_Body; - -- To ensure that a body is allowed - - ----------------------------------------- - -- Implementation of Task_Info Feature -- - ----------------------------------------- - - -- The Task_Info pragma: - - -- pragma Task_Info (EXPRESSION); - - -- allows the specification on a task by task basis of a value of type - -- System.Task_Info.Task_Info_Type to be passed to a task when it is - -- created. The specification of this type, and the effect on the task - -- that is created is target dependent. - - -- The Task_Info pragma appears within a task definition (compare the - -- definition and implementation of pragma Priority). If no such pragma - -- appears, then the value Unspecified_Task_Info is passed. If a pragma - -- is present, then it supplies an alternative value. If the argument of - -- the pragma is a discriminant reference, then the value can be set on - -- a task by task basis by supplying the appropriate discriminant value. - - -- Note that this means that the type used for Task_Info_Type must be - -- suitable for use as a discriminant (i.e. a scalar or access type). - - ------------------ - -- Declarations -- - ------------------ - - type Scope_Type is - (Process_Scope, - -- Contend only with threads in same process - - System_Scope, - -- Contend with all threads on same CPU - - Default_Scope); - - type Thread_Attributes is record - Bind_To_Cpu_Number : Integer; - -- -1: Do nothing - -- 0: Unbind - -- 1-N: Bind all unbound threads to this CPU - - Contention_Scope : Scope_Type; - end record; - - type Task_Info_Type is access all Thread_Attributes; - -- Type used for passing information to task create call, using the - -- Task_Info pragma. This type may be specialized for individual - -- implementations, but it must be a type that can be used as a - -- discriminant (i.e. a scalar or access type). - - Unspecified_Thread_Attribute : aliased Thread_Attributes := - Thread_Attributes'(-1, Default_Scope); - - Unspecified_Task_Info : constant Task_Info_Type := - Unspecified_Thread_Attribute'Access; - -- Value passed to task in the absence of a Task_Info pragma - -- Don't call new here because the tasking run time has not been - -- elaborated yet, so calling Task_Lock is unsafe. - -end System.Task_Info; diff --git a/gcc/ada/s-taspri-tru64.ads b/gcc/ada/s-taspri-tru64.ads deleted file mode 100644 index 41c9aeaa3cd..00000000000 --- a/gcc/ada/s-taspri-tru64.ads +++ /dev/null @@ -1,119 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-2011, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 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 the DEC Unix 4.0 version of this package - --- This package provides low-level support for most tasking features - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - -with Interfaces.C; - -with System.OS_Interface; - -package System.Task_Primitives is - pragma Preelaborate; - - type Lock is limited private; - -- Should be used for implementation of protected objects - - type RTS_Lock is limited private; - -- Should be used inside the runtime system. The difference between Lock - -- and the RTS_Lock is that the later one serves only as a semaphore so - -- that do not check for ceiling violations. - - type Suspension_Object is limited private; - -- Should be used for the implementation of Ada.Synchronous_Task_Control - - type Task_Body_Access is access procedure; - -- Pointer to the task body's entry point (or possibly a wrapper - -- declared local to the GNARL). - - type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task basis. - -- A component of this type is guaranteed to be included - - subtype Task_Address is System.Address; - -- In some versions of Task_Primitives, notably for VMS, Task_Address is - -- the short version of address defined in System.Aux_DEC. To avoid - -- dragging Aux_DEC into tasking packages a tasking specific subtype is - -- defined here. - - Task_Address_Size : constant := Standard'Address_Size; - -- The size of Task_Address - - Alternate_Stack_Size : constant := 0; - -- No alternate signal stack is used on this platform - -private - - type Lock is record - L : aliased System.OS_Interface.pthread_mutex_t; - Ceiling : Interfaces.C.int; - end record; - - type RTS_Lock is new System.OS_Interface.pthread_mutex_t; - - type Suspension_Object is record - State : Boolean; - pragma Atomic (State); - -- Boolean that indicates whether the object is open. This field is - -- marked Atomic to ensure that we can read its value without locking - -- the access to the Suspension_Object. - - Waiting : Boolean; - -- Flag showing if there is a task already suspended on this object - - L : aliased System.OS_Interface.pthread_mutex_t; - -- Protection for ensuring mutual exclusion on the Suspension_Object - - CV : aliased System.OS_Interface.pthread_cond_t; - -- Condition variable used to queue threads until the is signaled - end record; - - type Private_Data is record - Thread : aliased System.OS_Interface.pthread_t; - pragma Atomic (Thread); - -- Thread field may be updated by two different threads of control. - -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same - -- value (thr_self value). We do not want to use lock on those - -- operations and the only thing we have to make sure is that they are - -- updated in atomic fashion. - - CV : aliased System.OS_Interface.pthread_cond_t; - - L : aliased RTS_Lock; - -- Protection for all components is lock L - end record; - -end System.Task_Primitives; diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index bfe7bce3278..6d77a76ea49 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -252,7 +252,7 @@ __gnat_ttyname (int filedes) #endif #if defined (linux) || defined (sun) || defined (sgi) \ - || (defined (__osf__) && ! defined (__alpha_vxworks)) || defined (WINNT) \ + || ! defined (__alpha_vxworks) || defined (WINNT) \ || defined (__MACHTEN__) || defined (__hpux__) || defined (_AIX) \ || (defined (__svr4__) && defined (i386)) || defined (__Lynx__) \ || defined (__CYGWIN__) || defined (__FreeBSD__) || defined (__OpenBSD__) \ @@ -310,7 +310,7 @@ getc_immediate_common (FILE *stream, int waiting) { #if defined (linux) || defined (sun) || defined (sgi) \ - || (defined (__osf__) && ! defined (__alpha_vxworks)) \ + || ! defined (__alpha_vxworks) \ || defined (__CYGWIN32__) || defined (__MACHTEN__) || defined (__hpux__) \ || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ || defined (__Lynx__) || defined (__FreeBSD__) || defined (__OpenBSD__) \ @@ -331,7 +331,7 @@ getc_immediate_common (FILE *stream, termios_rec.c_lflag = termios_rec.c_lflag & ~ICANON & ~ECHO; #if defined(linux) || defined (sun) || defined (sgi) \ - || defined (__osf__) || defined (__MACHTEN__) || defined (__hpux__) \ + || defined (__MACHTEN__) || defined (__hpux__) \ || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ || defined (__Lynx__) || defined (__FreeBSD__) || defined (__OpenBSD__) \ || defined (__GLIBC__) || defined (__APPLE__) @@ -842,11 +842,11 @@ __gnat_localtime_tzoff (const time_t *timer, const int *is_historic, long *off) (*Unlock_Task) (); } -/* Darwin, Free BSD, Linux, Tru64, where component tm_gmtoff is present in +/* Darwin, Free BSD, Linux, where component tm_gmtoff is present in struct tm */ #elif defined (__APPLE__) || defined (__FreeBSD__) || defined (linux) ||\ - (defined (__alpha__) && defined (__osf__)) || defined (__GLIBC__) + defined (__GLIBC__) { localtime_r (timer, &tp); *off = tp.tm_gmtoff; diff --git a/gcc/ada/system-tru64.ads b/gcc/ada/system-tru64.ads deleted file mode 100644 index 43facc7465f..00000000000 --- a/gcc/ada/system-tru64.ads +++ /dev/null @@ -1,214 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (DEC Unix Version) -- --- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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. -- --- -- ------------------------------------------------------------------------------- - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; - - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := 63; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 1024.0; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 64; - Memory_Size : constant := 2 ** 64; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 60; - Max_Interrupt_Priority : constant Positive := 63; - - subtype Any_Priority is Integer range 0 .. 63; - subtype Priority is Any_Priority range 0 .. 60; - subtype Interrupt_Priority is Any_Priority range 61 .. 63; - - Default_Priority : constant Priority := 30; - -private - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := False; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := True; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - -- Note: Denorm is False because denormals are only handled properly - -- if the -mieee switch is set, and we do not require this usage. - - --------------------------- - -- Underlying Priorities -- - --------------------------- - - -- Important note: this section of the file must come AFTER the - -- definition of the system implementation parameters to ensure - -- that the value of these parameters is available for analysis - -- of the declarations here (using Rtsfind at compile time). - - -- The underlying priorities table provides a generalized mechanism - -- for mapping from Ada priorities to system priorities. In some - -- cases a 1-1 mapping is not the convenient or optimal choice. - - -- For Dec Unix 4.0d, we use a default 1-to-1 mapping that provides - -- the full range of 64 priorities available from the operating system. - - -- On DU prior to 4.0d, less than 64 priorities are available so there - -- are two possibilities: - - -- Limit your range of priorities to the range provided by the - -- OS (e.g 16 .. 32 on 4.0b) - - -- Replace the standard table as described below - - -- To replace the default values of the Underlying_Priorities mapping, - -- copy this source file into your build directory, edit the file to - -- reflect your desired behavior, and recompile with the command: - - -- $ gcc -c -O3 -gnatpgn system.ads - - -- then recompile the run-time parts that depend on this package: - - -- $ gnatmake -a -gnatn -O3 <your application> - - -- then force rebuilding your application if you need different options: - - -- $ gnatmake -f <your options> <your application> - - type Priorities_Mapping is array (Any_Priority) of Integer; - pragma Suppress_Initialization (Priorities_Mapping); - -- Suppress initialization in case gnat.adc specifies Normalize_Scalars - - Underlying_Priorities : constant Priorities_Mapping := - - (Priority'First => 0, - - 1 => 1, 2 => 2, 3 => 3, 4 => 4, 5 => 5, - 6 => 6, 7 => 7, 8 => 8, 9 => 9, 10 => 10, - 11 => 11, 12 => 12, 13 => 13, 14 => 14, 15 => 15, - 16 => 16, 17 => 17, 18 => 18, 19 => 19, 20 => 20, - 21 => 21, 22 => 22, 23 => 23, 24 => 24, 25 => 25, - 26 => 26, 27 => 27, 28 => 28, 29 => 29, - - Default_Priority => 30, - - 31 => 31, 32 => 32, 33 => 33, 34 => 34, 35 => 35, - 36 => 36, 37 => 37, 38 => 38, 39 => 39, 40 => 40, - 41 => 41, 42 => 42, 43 => 43, 44 => 44, 45 => 45, - 46 => 46, 47 => 47, 48 => 48, 49 => 49, 50 => 50, - 51 => 51, 52 => 52, 53 => 53, 54 => 54, 55 => 55, - 56 => 56, 57 => 57, 58 => 58, 59 => 59, - - Priority'Last => 60, - - 61 => 61, 62 => 62, - - Interrupt_Priority'Last => 63); - -end System; diff --git a/gcc/ada/terminals.c b/gcc/ada/terminals.c index 18a4f2a29bc..cb1414a96df 100644 --- a/gcc/ada/terminals.c +++ b/gcc/ada/terminals.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 2008-2011, AdaCore * + * Copyright (C) 2008-2012, AdaCore * * * * 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- * @@ -976,9 +976,6 @@ __gnat_setup_winsize (void *desc, int rows, int columns) || defined (__DragonFly__) # define FREEBSD #endif -#if defined (__alpha__) && defined (__osf__) -# define OSF1 -#endif #if defined (__mips) && defined (__sgi) # define IRIX #endif @@ -1048,18 +1045,6 @@ __gnat_setup_winsize (void *desc, int rows, int columns) #define USE_CLONE_DEVICE "/dev/ptmx" #elif defined (_AIX) #define USE_CLONE_DEVICE "/dev/ptc" -#elif defined (OSF1) -/* On Tru64, the systems offers various interfaces to open a terminal: - - /dev/ptmx: this the system V driver (stream based), - - /dev/ptmx_bsd: the non stream based clone device, - - the openpty function which use BSD interface. - - Using directly /dev/ptmx_bsd on Tru64 5.1B seems to consume all the - available slave ptys (why ?). When using openpty it seems that the function - handles the creation of entries in /dev/pts when necessary and so avoid this - starvation issue. The pty man entry suggests also to use openpty. -*/ -#define USE_OPENPTY #elif defined (__hpux__) /* On HP-UX we use the streamed version. Using the non streamed version is not recommanded (through "/dev/ptym/clone"). Indeed it seems that there are |