From patchwork Sat Jun 16 14:42:38 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Thomas Schwinge X-Patchwork-Id: 165295 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 811FEB70EF for ; Sun, 17 Jun 2012 00:43:33 +1000 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1340462614; h=Comment: DomainKey-Signature:Received:Received:Received:Received:Received: From:To:Cc:Subject:Date:Message-Id:MIME-Version:Content-Type: Content-Transfer-Encoding:Mailing-List:Precedence:List-Id: List-Unsubscribe:List-Archive:List-Post:List-Help:Sender: Delivered-To; bh=x1g2ZKIPKaiH6hPIe6ekeEnO4Ao=; b=umwslRh0n27/EQj 7Ynoa8pQS3a7ZH0hfUESPdg7D/Acys6Iy+uy2OSM44mfvWjzkVWQ0mH52KACL81w ZrWH/t6Yr8YR8KgjiawAZdtjcMR6uW9G78ikaSTbcttFClalWN0umjPyUm3j3TKV 70HqFP4ej4PhhJXXPnVXUOp9vpis= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Received:From:To:Cc:Subject:Date:Message-Id:MIME-Version:Content-Type:Content-Transfer-Encoding:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=pCA2b4NTfEikoeWWJ+GZmQ1b4Vh0Bfq7Qro2Xd0HucZynoT2qv3tio9iY0tCSQ /5d3iYOtMxiCVfJClvdqBe1RpN3uiqsBTsHsvq1yXcK1vUZaKZFuvCFOEzNdgE/7 FfBru2IxZFVi8nWUmIy6L18eGnX8BgWlbxcAJND8Yh1mY=; Received: (qmail 6923 invoked by alias); 16 Jun 2012 14:43:28 -0000 Received: (qmail 6887 invoked by uid 22791); 16 Jun 2012 14:43:20 -0000 X-SWARE-Spam-Status: No, hits=0.3 required=5.0 tests=AWL, BAYES_50, KHOP_RCVD_UNTRUST, RCVD_IN_HOSTKARMA_W, RCVD_IN_HOSTKARMA_WL, SARE_BAYES_5x7, SARE_BAYES_6x7, SARE_BAYES_7x7, SARE_SUB_ENC_UTF8, TBC, TW_LR, TW_RW, T_FILL_THIS_FORM_SHORT X-Spam-Check-By: sourceware.org Received: from relay1.mentorg.com (HELO relay1.mentorg.com) (192.94.38.131) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Sat, 16 Jun 2012 14:42:57 +0000 Received: from nat-ies.mentorg.com ([192.94.31.2] helo=EU1-MAIL.mgc.mentorg.com) by relay1.mentorg.com with esmtp id 1SfuDG-0000tn-8G from Thomas_Schwinge@mentor.com ; Sat, 16 Jun 2012 07:42:55 -0700 Received: from feldtkeller.schwinge.homeip.net ([172.30.72.5]) by EU1-MAIL.mgc.mentorg.com with Microsoft SMTPSVC(6.0.3790.1830); Sat, 16 Jun 2012 15:42:49 +0100 From: Thomas Schwinge To: gcc-patches@gcc.gnu.org Cc: svante.signell@telia.com, bosch@gnat.com, dewar@gnat.com, charlet@act-europe.fr, ebotcazou@libertysurf.fr Subject: =?UTF-8?q?=5BPATCH=5D=20GCC=20Ada/GNAT=20configuration=20for=20GNU/Hurd?= Date: Sat, 16 Jun 2012 16:42:38 +0200 Message-Id: <1339857758-5032-1-git-send-email-thomas@codesourcery.com> MIME-Version: 1.0 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Hi! Here is a patch that adds a basic GCC Ada/GNAT configuration for x86 GNU/Hurd. This has originally been created by Svante Signell for use with Debian's GCC 4.6 package, and now I have ported it to trunk, and also applied some further changes. 2012-06-16 Svante Signell Thomas Schwinge gcc/ada/ * gcc-interface/Makefile.in: Add configuration for x86 GNU/Hurd. * gsocket.h [__GNU__] (Has_Sockaddr_Len): #define to 1. * s-oscons-tmplt.c: Add checks for __GNU__ next to several __linux__ and linux conditionals. * terminals.c [__GNU__]: Don't #include . #define USE_GETPT. * s-osinte-gnu.ads: New file. * s-taprop-gnu.adb: Likewise. There is still room for improvement (and I plan to work on that), but the test results look very good already, so I'd like to check this in, OK? === acats Summary === # of expected passes 2311 # of unexpected failures 9 *** FAILURES: c23003b c23003g c23003i c52103x c52104x c52104y cb1010a cb1010c cb1010d === gnat Summary === # of expected passes 1101 # of unexpected failures 7 # of expected failures 17 # of unsupported tests 4 [...]/hurd/master.build/gcc/gnatmake version 4.8.0 20120606 (experimental) Are there any other Ada testsuites to run? Grüße, Thomas --- gcc/ada/gcc-interface/Makefile.in | 29 + gcc/ada/gsocket.h | 3 +- gcc/ada/s-oscons-tmplt.c | 13 +- gcc/ada/s-osinte-gnu.ads | 723 ++++++++++++++++++++ gcc/ada/s-taprop-gnu.adb | 1346 +++++++++++++++++++++++++++++++++++++ gcc/ada/terminals.c | 4 +- 6 files changed, 2109 insertions(+), 9 deletions(-) diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 21c2471..936338b 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -1274,6 +1274,35 @@ ifeq ($(strip $(filter-out %86_64 freebsd%,$(arch) $(osys))),) MISCLIB = -lutil endif +# x86 GNU/Hurd +ifeq ($(strip $(filter-out %86 gnu%,$(arch) $(osys))),) + LIBGNAT_TARGET_PAIRS = \ + a-intnam.ads #endif -#ifdef __linux__ +#if defined (__linux__) || defined (__GNU__) # include # include #endif @@ -921,7 +921,7 @@ CND(VEOL2, "Alternative EOL") */ -#if defined (__FreeBSD__) || defined (linux) +#if defined (__FreeBSD__) || defined (linux) || defined (__GNU__) # define PTY_Library "-lutil" #else # define PTY_Library "" @@ -1098,7 +1098,7 @@ CND(MSG_WAITALL, "Wait for full reception") #endif CND(MSG_NOSIGNAL, "No SIGPIPE on send") -#ifdef __linux__ +#if defined (__linux__) || defined (__GNU__) # define MSG_Forced_Flags "MSG_NOSIGNAL" #else # define MSG_Forced_Flags "0" @@ -1263,7 +1263,7 @@ CND(SIZEOF_struct_hostent, "struct hostent"); #define SIZEOF_struct_servent (sizeof (struct servent)) CND(SIZEOF_struct_servent, "struct servent"); -#if defined (__linux__) +#if defined (__linux__) || defined (__GNU__) #define SIZEOF_sigset (sizeof (sigset_t)) CND(SIZEOF_sigset, "sigset"); #endif @@ -1365,7 +1365,8 @@ CND(CLOCK_THREAD_CPUTIME_ID, "Thread CPU clock") CNS(CLOCK_RT_Ada, "") #endif -#if defined (__APPLE__) || defined (__linux__) || defined (DUMMY) +#if defined (__APPLE__) || defined (__linux__) || defined (__GNU__) \ + || defined (DUMMY) /* -- Sizes of pthread data types diff --git a/gcc/ada/s-osinte-gnu.ads b/gcc/ada/s-osinte-gnu.ads new file mode 100644 index 0000000..17518a6 --- /dev/null +++ b/gcc/ada/s-osinte-gnu.ads @@ -0,0 +1,723 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA 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. -- +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNARL 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 GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the GNU/Hurd version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- 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 Ada.Unchecked_Conversion; +with Interfaces.C; +with System.OS_Constants; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-lpthread"); + pragma Linker_Options ("-lrt"); + + subtype int is Interfaces.C.int; + subtype char is Interfaces.C.char; + 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; + + ----------- + -- Errno -- + ----------- + -- From /usr/include/i386-gnu/bits/errno.h + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 1073741859; + EINTR : constant := 1073741828; + EINVAL : constant := 1073741846; + ENOMEM : constant := 1073741836; + EPERM : constant := 1073741825; + ETIMEDOUT : constant := 1073741884; + + ------------- + -- Signals -- + ------------- + -- From /usr/include/i386-gnu/bits/signum.h + + Max_Interrupt : constant := 32; + 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) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + 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 + 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 + SIGCLD : constant := 20; -- alias for SIGCHLD + SIGCHLD : constant := 20; -- child status change + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) + SIGPOLL : constant := 23; -- I/O possible (same as SIGIO?) + 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 (NetBSD/FreeBSD) + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + SIGLOST : constant := 32; -- Resource lost (Sun); server died (GNU) +-- SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal +-- SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal +-- SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal + + SIGADAABORT : constant := SIGABRT; + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := ( + SIGTRAP, + -- To enable debugging on multithreaded applications, mark SIGTRAP to + -- be kept unmasked. + + SIGBUS, + + SIGTTIN, SIGTTOU, SIGTSTP, + -- Keep these three signals unmasked so that background processes + -- and IO behaves as normal "C" applications + + SIGPROF, + -- To avoid confusing the profiler + + SIGKILL, SIGSTOP); + -- These two signals actually cannot be masked; + -- POSIX simply won't allow it. + + Reserved : constant Signal_Set := + -- I am not sure why the following signal is reserved. + -- I guess they are not supported by this version of GNU/Hurd. + (0 .. 0 => SIGVTALRM); + + type sigset_t is private; + + -- From /usr/include/signal.h /usr/include/i386-gnu/bits/sigset.h + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + -- sigcontext is architecture dependent, so define it private + type struct_sigcontext is private; + + -- From /usr/include/i386-gnu/bits/sigaction.h: Note: arg. order differs + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, struct_sigaction); + + type struct_sigaction_ptr is access all struct_sigaction; + + -- From /usr/include/i386-gnu/bits/sigaction.h + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + -- From /usr/include/i386-gnu/bits/signum.h + SIG_ERR : constant := 1; + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + SIG_HOLD : constant := 2; + + -- From /usr/include/i386-gnu/bits/sigaction.h + SA_SIGINFO : constant := 16#0040#; + SA_ONSTACK : constant := 16#0001#; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := True; + -- Indicates whether time slicing is supported (i.e SCHED_RR is supported) + + type timespec is private; + + function nanosleep (rqtp, rmtp : access timespec) return int; + pragma Import (C, nanosleep, "nanosleep"); + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + -- From: /usr/include/time.h + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) + return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + -- From: /usr/include/unistd.h + function sysconf (name : int) return long; + pragma Import (C, sysconf); + + -- From /usr/include/i386-gnu/bits/confname.h + SC_CLK_TCK : constant := 2; + SC_NPROCESSORS_ONLN : constant := 84; + + ------------------------- + -- Priority Scheduling -- + ------------------------- + -- From /usr/include/i386-gnu/bits/sched.h + + SCHED_OTHER : constant := 0; + SCHED_FIFO : constant := 1; + SCHED_RR : constant := 2; + + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int; + -- Maps System.Any_Priority to a POSIX priority. + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + -- From: /usr/include/signal.h + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + -- From: /usr/include/unistd.h + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + -- From: /usr/include/pthread/pthread.h + function lwp_self return System.Address; + -- lwp_self does not exist on this thread library, revert to pthread_self + -- which is the closest approximation (with getpid). This function is + -- needed to share 7staprop.adb across POSIX-like targets. + pragma Import (C, lwp_self, "pthread_self"); + + ------------- + -- 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); + + -- From: /usr/include/bits/pthread.h:typedef int __pthread_t; + -- /usr/include/pthread/pthreadtypes.h:typedef __pthread_t pthread_t; + type pthread_t is new unsigned_long; + subtype Thread_Id is pthread_t; + + function To_pthread_t is new Ada.Unchecked_Conversion + (unsigned_long, pthread_t); + + type pthread_mutex_t is limited private; + type pthread_rwlock_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_rwlockattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + -- From /usr/include/pthread/pthreadtypes.h + PTHREAD_CREATE_DETACHED : constant := 1; + PTHREAD_CREATE_JOINABLE : constant := 0; + + PTHREAD_SCOPE_PROCESS : constant := 1; + PTHREAD_SCOPE_SYSTEM : constant := 0; + + ----------- + -- Stack -- + ----------- + + -- From: /usr/include/i386-gnu/bits/sigstack.h + type stack_t is record + ss_sp : System.Address; + ss_size : size_t; + ss_flags : int; + end record; + pragma Convention (C, stack_t); + + function sigaltstack + (ss : not null access stack_t; + oss : access stack_t) return int; + pragma Import (C, sigaltstack, "sigaltstack"); + + Alternate_Stack : aliased System.Address; + -- This is a dummy definition, never used (Alternate_Stack_Size is null) + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + + Stack_Base_Available : constant Boolean := False; + -- Indicates whether 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. + + -- From: /usr/include/i386-gnu/bits/shm.h __getpagesize or getpagesize?? + 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 + + -- From /usr/include/i386-gnu/bits/mman.h + PROT_NONE : constant := 0; + PROT_READ : constant := 4; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 1; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + PROT_ON : constant := PROT_NONE; + PROT_OFF : constant := PROT_ALL; + + -- From /usr/include/i386-gnu/bits/mman.h + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + pragma Inline (pthread_init); + -- This is a dummy procedure to share some GNULLI files + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + -- From: /usr/include/signal.h: + -- sigwait (__const sigset_t *__restrict __set, int *__restrict __sig) + function sigwait (set : access sigset_t; sig : access Signal) return int; + pragma Import (C, sigwait, "sigwait"); + + -- From: /usr/include/pthread/pthread.h: + -- extern int pthread_kill (pthread_t thread, int signo); + function pthread_kill (thread : pthread_t; sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + -- From: /usr/include/i386-gnu/bits/sigthread.h + -- extern int pthread_sigmask (int __how, __const __sigset_t *__newmask, + -- __sigset_t *__oldmask) __THROW; + function pthread_sigmask + (how : int; + set : access sigset_t; + oset : access sigset_t) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + -- From: /usr/include/pthread/pthread.h and + -- /usr/include/pthread/pthreadtypes.h + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_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_rwlockattr_init + (attr : access pthread_rwlockattr_t) return int; + pragma Import (C, pthread_rwlockattr_init, "pthread_rwlockattr_init"); + + function pthread_rwlockattr_destroy + (attr : access pthread_rwlockattr_t) return int; + pragma Import (C, pthread_rwlockattr_destroy, "pthread_rwlockattr_destroy"); + + function pthread_rwlock_init + (mutex : access pthread_rwlock_t; + attr : access pthread_rwlockattr_t) return int; + pragma Import (C, pthread_rwlock_init, "pthread_rwlock_init"); + + function pthread_rwlock_destroy + (mutex : access pthread_rwlock_t) return int; + pragma Import (C, pthread_rwlock_destroy, "pthread_rwlock_destroy"); + + function pthread_rwlock_rdlock (mutex : access pthread_rwlock_t) return int; + pragma Import (C, pthread_rwlock_rdlock, "pthread_rwlock_rdlock"); + + function pthread_rwlock_wrlock (mutex : access pthread_rwlock_t) return int; + pragma Import (C, pthread_rwlock_wrlock, "pthread_rwlock_wrlock"); + + function pthread_rwlock_unlock (mutex : access pthread_rwlock_t) return int; + pragma Import (C, pthread_rwlock_unlock, "pthread_rwlock_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_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"); + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + -- From /usr/include/pthread/pthreadtypes.h + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_PROTECT : constant := 2; + PTHREAD_PRIO_INHERIT : constant := 1; + + -- From: /usr/include/pthread/pthread.h + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol, + "pthread_mutexattr_setprotocol"); + + function pthread_mutexattr_getprotocol + (attr : access pthread_mutexattr_t; + protocol : access int) return int; + pragma Import (C, pthread_mutexattr_getprotocol, + "pthread_mutexattr_getprotocol"); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import (C, pthread_mutexattr_setprioceiling, + "pthread_mutexattr_setprioceiling"); + + function pthread_mutexattr_getprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : access int) return int; + pragma Import (C, pthread_mutexattr_getprioceiling, + "pthread_mutexattr_getprioceiling"); + + type struct_sched_param is record + sched_priority : int; -- scheduling priority + end record; + pragma Convention (C, struct_sched_param); + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_getscope + (attr : access pthread_attr_t; + contentionscope : access int) return int; + pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope"); + + 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_getinheritsched + (attr : access pthread_attr_t; + inheritsched : access int) return int; + pragma Import (C, pthread_attr_getinheritsched, + "pthread_attr_getinheritsched"); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy, "pthread_setschedpolicy"); + + function sched_yield return int; + pragma Import (C, sched_yield, "sched_yield"); + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import + (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate"); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); + + -- From: /usr/include/pthread/pthread.h + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + pragma Convention (C, destructor_pointer); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + + -- From /usr/include/i386-gnu/bits/sched.h + -- 1_024 == 1024?? + CPU_SETSIZE : constant := 1_024; + + type bit_field is array (1 .. CPU_SETSIZE) of Boolean; + for bit_field'Size use CPU_SETSIZE; + pragma Pack (bit_field); + pragma Convention (C, bit_field); + + type cpu_set_t is record + bits : bit_field; + end record; + pragma Convention (C, cpu_set_t); + + -- function pthread_setaffinity_np + -- (thread : pthread_t; + -- cpusetsize : size_t; + -- cpuset : access cpu_set_t) return int; + -- pragma Import (C, pthread_setaffinity_np, + -- "__gnat_pthread_setaffinity_np"); + +private + + type sigset_t is array (1 .. 4) of unsigned; + + -- FIXME: + -- In GNU/Hurd the component sa_handler turns out to + -- be one a union type, and the selector is a macro: + -- #define sa_handler __sigaction_handler.sa_handler + -- #define sa_sigaction __sigaction_handler.sa_sigaction + + -- In FreeBSD the component sa_handler turns out to + -- be one a union type, and the selector is a macro: + -- #define sa_handler __sigaction_u._handler + -- #define sa_sigaction __sigaction_u._sigaction + + -- Should we add a signal_context type here ? + -- How could it be done independent of the CPU architecture ? + -- sigcontext type is opaque, so it is architecturally neutral. + -- It is always passed as an access type, so define it as an empty record + -- since the contents are not used anywhere. + type struct_sigcontext is null record; + pragma Convention (C, struct_sigcontext); + + type pid_t is new int; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 0; + + type unsigned_long_long_t is mod 2 ** 64; + + subtype char_array is Interfaces.C.char_array; + + type pthread_attr_t is record + Data : char_array (1 .. OS_Constants.PTHREAD_ATTR_SIZE); + end record; + pragma Convention (C, pthread_attr_t); + for pthread_attr_t'Alignment use Interfaces.C.unsigned_long'Alignment; + + type pthread_condattr_t is record + Data : char_array (1 .. OS_Constants.PTHREAD_CONDATTR_SIZE); + end record; + pragma Convention (C, pthread_condattr_t); + for pthread_condattr_t'Alignment use Interfaces.C.int'Alignment; + + type pthread_mutexattr_t is record + Data : char_array (1 .. OS_Constants.PTHREAD_MUTEXATTR_SIZE); + end record; + pragma Convention (C, pthread_mutexattr_t); + for pthread_mutexattr_t'Alignment use Interfaces.C.int'Alignment; + + type pthread_mutex_t is record + Data : char_array (1 .. OS_Constants.PTHREAD_MUTEX_SIZE); + end record; + pragma Convention (C, pthread_mutex_t); + for pthread_mutex_t'Alignment use Interfaces.C.unsigned_long'Alignment; + + type pthread_rwlockattr_t is record + Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCKATTR_SIZE); + end record; + pragma Convention (C, pthread_rwlockattr_t); + for pthread_rwlockattr_t'Alignment use Interfaces.C.unsigned_long'Alignment; + + type pthread_rwlock_t is record + Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCK_SIZE); + end record; + pragma Convention (C, pthread_rwlock_t); + for pthread_rwlock_t'Alignment use Interfaces.C.unsigned_long'Alignment; + + type pthread_cond_t is record + Data : char_array (1 .. OS_Constants.PTHREAD_COND_SIZE); + end record; + pragma Convention (C, pthread_cond_t); + for pthread_cond_t'Alignment use unsigned_long_long_t'Alignment; + + type pthread_key_t is new int; + +end System.OS_Interface; diff --git a/gcc/ada/s-taprop-gnu.adb b/gcc/ada/s-taprop-gnu.adb new file mode 100644 index 0000000..8937876 --- /dev/null +++ b/gcc/ada/s-taprop-gnu.adb @@ -0,0 +1,1346 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a GNU/Hurd version of this package +-- Note: Removed the SCHED_FIFO and Ceiling Locking from the posix version +-- since these functions are not (yet) supported on GNU/Hurd + +-- 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 Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +with Interfaces.C; + +with System.Tasking.Debug; +with System.Interrupt_Management; +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 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 + + -- The followings are internal configuration constants needed + + Next_Serial_Number : Task_Serial_Number := 100; + -- We start at 100, to reserve some special values for + -- using in error checking. + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads) + + Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0; + -- Whether to use an alternate signal stack for stack overflows + + 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. + -- See also comment before body, below. + + function To_Address is + new Ada.Unchecked_Conversion (Task_Id, System.Address); + + ------------------- + -- Abort_Handler -- + ------------------- + + -- Target-dependent binding of inter-thread Abort signal to the raising of + -- the Abort_Signal exception. + + -- The technical issues and alternatives here are essentially the + -- same as for raising exceptions in response to other signals + -- (e.g. Storage_Error). See code and comments in the package body + -- System.Interrupt_Management. + + -- Some implementations may not allow an exception to be propagated out of + -- a handler, and others might leave the signal or interrupt that invoked + -- this handler masked after the exceptional return to the application + -- code. + + -- GNAT exceptions are originally implemented using setjmp()/longjmp(). On + -- most UNIX systems, this will allow transfer out of a signal handler, + -- which is usually the only mechanism available for implementing + -- asynchronous handlers of this kind. However, some systems do not + -- restore the signal mask on longjmp(), leaving the abort signal masked. + + 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 -- + ----------------- + + procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is + Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread); + Guard_Page_Address : Address; + + Res : Interfaces.C.int; + + begin + if Stack_Base_Available then + + -- Compute the guard page address + + Guard_Page_Address := + Stack_Base - (Stack_Base mod Get_Page_Size) + Get_Page_Size; + + Res := + mprotect (Guard_Page_Address, Get_Page_Size, + prot => (if On then PROT_ON else PROT_OFF)); + pragma Assert (Res = 0); + end if; + 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 + pragma Unreferenced (Prio); + + 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 with "Failed to allocate a lock"; + end if; + + Result := pthread_mutex_init (L.WO'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 with "Failed to allocate a lock"; + 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.WO'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; + + begin + Result := pthread_mutex_lock (L.WO'Access); + + -- Assume that the cause of EINVAL is a priority ceiling violation + + Ceiling_Violation := (Result = EINVAL); + pragma Assert (Result = 0 or else Result = EINVAL); + 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.WO'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 : Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; + Rel_Time : Duration; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + Timedout := True; + Yielded := False; + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time); + end if; + + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); + end if; + end if; + + if Abs_Time > Check_Time then + Request := + To_Timespec (if Relative_Timed_Wait then Rel_Time else 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; + Rel_Time : Duration; + Request : aliased timespec; + + Result : Interfaces.C.int; + pragma Warnings (Off, Result); + + begin + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time); + end if; + + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); + end if; + end if; + + if Abs_Time > Check_Time then + Request := + To_Timespec (if Relative_Timed_Wait then Rel_Time else 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; + + Result := sched_yield; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + TS : aliased timespec; + Result : Interfaces.C.int; + begin + Result := clock_gettime + (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (TS); + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 10#1.0#E-6; + 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); + + begin + null; + 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 + Self_ID.Common.LL.Thread := pthread_self; + Self_ID.Common.LL.LWP := lwp_self; + + Specific.Set (Self_ID); + + if Use_Alternate_Stack then + declare + Stack : aliased stack_t; + Result : Interfaces.C.int; + begin + Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack; + Stack.ss_size := Alternate_Stack_Size; + Stack.ss_flags := 0; + Result := sigaltstack (Stack'Access, null); + pragma Assert (Result = 0); + end; + end if; + 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 + -- Give the task a unique serial number + + Self_ID.Serial_Number := Next_Serial_Number; + Next_Serial_Number := Next_Serial_Number + 1; + pragma Assert (Next_Serial_Number /= 0); + + 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; + Page_Size : constant Interfaces.C.size_t := Get_Page_Size; + Result : Interfaces.C.int; + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Address, Thread_Body); + + use System.Task_Info; + + begin + Adjusted_Stack_Size := + Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size); + + if Stack_Base_Available then + + -- If Stack Checking is supported then allocate 2 additional pages: + + -- In the worst case, stack is allocated at something like + -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages + -- to be sure the effective stack size is greater than what + -- has been asked. + + Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Page_Size; + end if; + + -- Round stack size as this is required by some OSes (Darwin) + + Adjusted_Stack_Size := Adjusted_Stack_Size + Page_Size - 1; + Adjusted_Stack_Size := + Adjusted_Stack_Size - Adjusted_Stack_Size mod 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); + + -- 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. + + 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 then + Set_Priority (T, Priority); + end if; + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_Id) is + Result : Interfaces.C.int; + Tmp : Task_Id := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + + 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; + + Free (Tmp); + + if Is_Self then + Specific.Set (null); + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + -- Mark this task as unknown, so that if Self is called, it won't + -- return a dangling pointer. + + Specific.Set (null); + 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); + pragma Assert (Result = 0); + + 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); + + 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; + + 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 + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + raise Storage_Error; + end if; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + 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 it is specified in (RM D.10(9)). Otherwise, it just leaves + -- the state 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 + -- (RM 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 (ARM D.10 par. 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; + + -- Initialize the lock used to synchronize chain of all ATCBs + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Specific.Initialize (Environment_Task); + + if Use_Alternate_Stack then + Environment_Task.Common.Task_Alternate_Stack := + Alternate_Stack'Address; + end if; + + -- 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; + + -- pragma CPU and dispatching domains for the environment task + + Set_Task_Affinity (Environment_Task); + end Initialize; + + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + begin + null; + end Set_Task_Affinity; + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/terminals.c b/gcc/ada/terminals.c index ca672c4..55ca047 100644 --- a/gcc/ada/terminals.c +++ b/gcc/ada/terminals.c @@ -986,7 +986,7 @@ __gnat_setup_winsize (void *desc, int rows, int columns) /* On some system termio is either absent or including it will disable termios (HP-UX) */ #if ! defined (__hpux__) && ! defined (FREEBSD) && \ - ! defined (__APPLE__) && ! defined(__rtems__) + ! defined (__APPLE__) && ! defined(__rtems__) && ! defined (__GNU__) # include #endif @@ -1033,7 +1033,7 @@ __gnat_setup_winsize (void *desc, int rows, int columns) /* Configurable part */ #if defined (__APPLE__) || defined (FREEBSD) #define USE_OPENPTY -#elif defined (linux) +#elif defined (linux) || defined (__GNU__) #define USE_GETPT #elif defined (sun) #define USE_CLONE_DEVICE "/dev/ptmx"