This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Ada support for Linux/GNU/PPC
- From: Corey Minyard <minyard at acm dot org>
- To: gcc-patches at gcc dot gnu dot org
- Date: Thu, 31 Jan 2002 22:47:33 -0600
- Subject: Ada support for Linux/GNU/PPC
I've pulled up the most current CVS sources on my Linux/PPC box, and I
actually have some semblance of getting Ada working on it, including
tasking. Patches are pretty small, and included.
I ran a suite of tests I have, and the only problem is some floating
point inaccuracies, which I'll work on sometime soon.
Pretty cool.
-Corey
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/decl.c,v
retrieving revision 1.9
diff -u -p -r1.9 decl.c
--- gcc/ada/decl.c 2001/12/17 21:19:32 1.9
+++ gcc/ada/decl.c 2002/02/01 04:22:32
@@ -1011,7 +1011,10 @@ gnat_to_gnu_entity (gnat_entity, gnu_exp
&& (AGGREGATE_TYPE_P (gnu_type)
&& ! (TREE_CODE (gnu_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (gnu_type))))
- static_p = 1;
+ {
+ static_p = 1;
+ const_flag = 0;
+ }
set_lineno (gnat_entity, ! global_bindings_p ());
gnu_decl = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
Index: misc.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/misc.c,v
retrieving revision 1.17
diff -u -p -r1.17 misc.c
--- gcc/ada/misc.c 2001/12/19 00:31:41 1.17
+++ gcc/ada/misc.c 2002/02/01 04:22:41
@@ -744,9 +744,11 @@ update_setjmp_buf (buf)
enum machine_mode sa_mode = Pmode;
rtx stack_save;
+#if 0 /* This seems to be broken, at least on PowerPC. - Corey Minyard */
#ifdef HAVE_save_stack_nonlocal
if (HAVE_save_stack_nonlocal)
sa_mode = insn_data [(int) CODE_FOR_save_stack_nonlocal].operand[0].mode;
+#endif
#endif
#ifdef STACK_SAVEAREA_MODE
Index: targtyps.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/targtyps.c,v
retrieving revision 1.1
diff -u -p -r1.1 targtyps.c
--- gcc/ada/targtyps.c 2001/10/02 14:57:55 1.1
+++ gcc/ada/targtyps.c 2002/02/01 04:23:09
@@ -91,12 +91,18 @@
#define DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2)
#endif
+#ifdef MAX_LONG_DOUBLE_TYPE_SIZE
+#ifndef WIDEST_HARDWARE_FP_SIZE
+#define WIDEST_HARDWARE_FP_SIZE MAX_LONG_DOUBLE_TYPE_SIZE
+#endif
+#else
#ifndef LONG_DOUBLE_TYPE_SIZE
#define LONG_DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2)
#endif
#ifndef WIDEST_HARDWARE_FP_SIZE
#define WIDEST_HARDWARE_FP_SIZE LONG_DOUBLE_TYPE_SIZE
+#endif
#endif
/* The following provide a functional interface for the front end Ada code
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.21
diff -u -p -r1.21 Makefile.in
--- gcc/ada/Makefile.in 2001/12/20 06:22:40 1.21
+++ gcc/ada/Makefile.in 2002/02/01 04:23:46
@@ -104,6 +104,10 @@ RMDIR = rm -rf
MKDIR = mkdir -p
AR = ar
AR_FLAGS = rc
+# Some systems may be missing symbolic links, regular links, or both.
+# Allow configure to check this and use "ln -s", "ln", or "cp" as appropriate.
+LN=@LN@
+LN_S=@LN_S@
# How to invoke ranlib.
RANLIB = ranlib
# Test to use to see whether ranlib exists on the system.
@@ -1207,6 +1211,26 @@ ifeq ($(strip $(filter-out %86 linux%,$(
THREADSLIB=
RT_FLAGS=-D__RT__
endif
+endif
+
+ifeq ($(strip $(filter-out powerpc% linux%,$(arch) $(osys))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4lintnam.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<7sintman.adb \
+ s-osinte.adb<5josinte.adb \
+ s-osinte.ads<5josinte.ads \
+ s-osprim.adb<7sosprim.adb \
+ s-taprop.adb<5jtaprop.adb \
+ s-taspri.ads<5itaspri.ads \
+ system.ads<5bsystem.ads
+
+ MLIB_TGT=5lml-tgt
+ MISCLIB=-laddr2line -lbfd
+ THREADSLIB=-lpthread
+ GNATLIB_SHARED=gnatlib-shared-dual
+ GMEM_LIB=gmemlib
+ LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
endif
ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),)
--- gcc/ada/5josinte.ads.ppcada Thu Jan 31 22:17:52 2002
+++ gcc/ada/5josinte.ads Thu Jan 31 22:20:59 2002
@@ -0,0 +1,530 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1991-2001 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a GNU/LinuxPPC (GNU/LinuxThreads) 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 Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lpthread");
+
+ 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 --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := 11;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ EPERM : constant := 1;
+ ETIMEDOUT : constant := 110;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 63;
+ 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; -- IOT instruction
+ SIGBUS : constant := 7; -- bus error
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGUSR1 : constant := 10; -- user defined signal 1
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGUSR2 : constant := 12; -- user defined signal 2
+ 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
+ SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux)
+ SIGCLD : constant := 17; -- alias for SIGCHLD
+ SIGCHLD : constant := 17; -- child status change
+ SIGCONT : constant := 18; -- stopped process has been continued
+ SIGSTOP : constant := 19; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 20; -- user stop requested from tty
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGURG : constant := 23; -- urgent condition on IO channel
+ 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
+ SIGPOLL : constant := 29; -- pollable event occurred
+ SIGIO : constant := 29; -- I/O now possible (4.2 BSD)
+ SIGPWR : constant := 30; -- power-fail restart
+ SIGUNUSED : constant := 31; -- unused signal (GNU/Linux)
+ SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
+ SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
+ SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
+
+ SIGLOST : constant := 29; -- File lock lost, not really there
+
+ 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.
+
+ SIGLTHRRES, SIGLTHRCAN, SIGLTHRDBG);
+ -- These three signals are used by GNU/LinuxThreads starting from
+ -- glibc 2.1 (future 2.2).
+
+ Reserved : constant Signal_Set :=
+ -- I am not sure why the following two signals are reserved.
+ -- I guess they are not supported by this version of GNU/Linux.
+ (SIGVTALRM, SIGUNUSED);
+
+ type sigset_t is private;
+
+ 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");
+
+ type union_type_3 is new String (1 .. 116);
+ type siginfo_t is record
+ si_signo : int;
+ si_code : int;
+ si_errno : int;
+ X_data : union_type_3;
+ end record;
+ pragma Convention (C, siginfo_t);
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : unsigned_long;
+ sa_restorer : System.Address;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ type unsigned_long_array is array (int range <>) of unsigned_long;
+ pragma Convention (C, unsigned_long_array);
+
+ type Machine_State is record
+ gpr : unsigned_long_array (0 .. 31);
+ nip : unsigned_long;
+ msr : unsigned_long;
+ orig_gpr3 : unsigned_long;
+ ctr : unsigned_long;
+ link : unsigned_long;
+ xer : unsigned_long;
+ ccr : unsigned_long;
+ mq : unsigned_long;
+ trap : unsigned_long;
+ dar : unsigned_long;
+ dsisr : unsigned_long;
+ result : unsigned_long;
+ end record;
+ type Machine_State_Ptr is access all Machine_State;
+
+ SIG_BLOCK : constant := 0;
+ SIG_UNBLOCK : constant := 1;
+ SIG_SETMASK : constant := 2;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ type timespec is private;
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ type struct_timeval is private;
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ function gettimeofday
+ (tv : access struct_timeval;
+ tz : System.Address := System.Null_Address) return int;
+ pragma Import (C, gettimeofday, "gettimeofday");
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_OTHER : constant := 0;
+ SCHED_FIFO : constant := 1;
+ SCHED_RR : constant := 2;
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ 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;
+
+ -----------
+ -- Stack --
+ -----------
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- This is a dummy procedure to share some GNULLI files
+
+ ---------------------------------------
+ -- 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, "sigwait");
+
+ function pthread_kill (thread : pthread_t; sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init, "pthread_cond_init");
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
+
+ function pthread_cond_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 --
+ --------------------------
+
+ 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_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import
+ (C, pthread_attr_setschedpolicy, "pthread_attr_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");
+
+ 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);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+private
+
+ type sigset_t is array (0 .. 31) of unsigned_long;
+ pragma Convention (C, sigset_t);
+ for sigset_t'Size use 1024;
+ -- This is for GNU libc version 2 but should be backward compatible with
+ -- other libc where sigset_t is smaller.
+
+ 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 struct_timeval is record
+ tv_sec : time_t;
+ tv_usec : time_t;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ type pthread_attr_t is record
+ detachstate : int;
+ schedpolicy : int;
+ schedparam : struct_sched_param;
+ inheritsched : int;
+ scope : int;
+ guardsize : size_t;
+ stackaddr_set : int;
+ stackaddr : System.Address;
+ stacksize : size_t;
+ end record;
+ pragma Convention (C_Pass_By_Copy, pthread_attr_t);
+
+ type pthread_condattr_t is record
+ dummy : int;
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ type pthread_mutexattr_t is record
+ mutexkind : int;
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type pthread_t is new unsigned_long;
+
+ type struct_pthread_queue is record
+ head : System.Address;
+ tail : System.Address;
+ end record;
+ pragma Convention (C, struct_pthread_queue);
+
+ type pthread_mutex_t is record
+ m_spinlock : int;
+ m_count : int;
+ m_owner : System.Address;
+ m_kind : int;
+ m_waiting : struct_pthread_queue;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+ type pthread_cond_t is record
+ c_spinlock : int;
+ c_waiting : struct_pthread_queue;
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new unsigned;
+
+end System.OS_Interface;
--- gcc/ada/5jtaprop.adb.ppcada Thu Jan 31 22:18:18 2002
+++ gcc/ada/5jtaprop.adb Thu Jan 31 22:21:40 2002
@@ -0,0 +1,1046 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.3 $
+-- --
+-- Copyright (C) 1991-2001, Florida State University --
+-- --
+-- 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a GNU/LinuxPPC (GNU/LinuxThreads) 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 System.Tasking.Debug;
+-- used for Known_Tasks
+
+with Interfaces.C;
+-- used for int
+-- size_t
+
+with System.Interrupt_Management;
+-- used for Keep_Unmasked
+-- Abort_Task_Interrupt
+-- Interrupt_ID
+
+with System.Interrupt_Management.Operations;
+-- used for Set_Interrupt_Mask
+-- All_Tasks_Mask
+pragma Elaborate_All (System.Interrupt_Management.Operations);
+
+with System.Parameters;
+-- used for Size_Type
+
+with System.Tasking;
+-- used for Ada_Task_Control_Block
+-- Task_ID
+
+with Ada.Exceptions;
+-- used for Raise_Exception
+-- Raise_From_Signal_Handler
+-- Exception_Id
+
+with System.Soft_Links;
+-- used for Defer/Undefer_Abort
+
+-- Note that we do not use System.Tasking.Initialization directly since
+-- this 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.Initialization
+
+with System.OS_Primitives;
+-- used for Delay_Modes
+
+with System.Soft_Links;
+-- used for Get_Machine_State_Addr
+
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+package body System.Task_Primitives.Operations is
+
+ use System.Tasking.Debug;
+ use System.Tasking;
+ use Interfaces.C;
+ use System.OS_Interface;
+ use System.Parameters;
+ use System.OS_Primitives;
+
+ package SSL renames System.Soft_Links;
+
+ ------------------
+ -- Local Data --
+ ------------------
+
+ Max_Stack_Size : constant := 2000 * 1024;
+ -- GNU/LinuxThreads does not return an error value when requesting
+ -- a task stack size which is too large, so we have to check this
+ -- ourselves.
+
+ -- The followings are logically constants, but need to be initialized
+ -- at run time.
+
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_ID associated with a thread
+
+ All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
+ -- See comments on locking rules in System.Tasking (spec).
+
+ 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.
+ Priority_Ceiling_Emulation : constant Boolean := True;
+
+ Next_Serial_Number : Task_Serial_Number := 100;
+ -- We start at 100, to reserve some special values for
+ -- using in error checking.
+ -- The following are internal configuration constants needed.
+
+ Time_Slice_Val : Integer;
+ pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
+
+ Dispatching_Policy : Character;
+ pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
+
+ FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
+ -- Indicates whether FIFO_Within_Priorities is set.
+
+ -- The following are effectively constants, but they need to
+ -- be initialized by calling a pthread_ function.
+
+ Mutex_Attr : aliased pthread_mutexattr_t;
+ Cond_Attr : aliased pthread_condattr_t;
+
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype int is Interfaces.C.int;
+
+ type unsigned_long_array is array (int range <>) of unsigned_long;
+ pragma Convention (C, unsigned_long_array);
+
+ type pt_regs is record
+ gpr : unsigned_long_array (0 .. 31);
+ nip : unsigned_long;
+ msr : unsigned_long;
+ orig_gpr3 : unsigned_long;
+ ctr : unsigned_long;
+ link : unsigned_long;
+ xer : unsigned_long;
+ ccr : unsigned_long;
+ mq : unsigned_long;
+ trap : unsigned_long;
+ dar : unsigned_long;
+ dsisr : unsigned_long;
+ result : unsigned_long;
+ end record;
+ pragma Convention (C, pt_regs);
+
+ type pt_regs_ptr is access all pt_regs;
+ pragma Convention (C, pt_regs_ptr);
+
+ type sigcontext is record
+ unused : unsigned_long_array (0 .. 3);
+ signal : int;
+ handler : unsigned_long;
+ oldmask : unsigned_long;
+ regs : pt_regs_ptr;
+ end record;
+ pragma Convention (C, sigcontext);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Abort_Handler
+ (signo : Signal;
+ context : sigcontext);
+
+ function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
+
+ function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+
+ function To_pthread_t is new Unchecked_Conversion
+ (Integer, System.OS_Interface.pthread_t);
+
+ -------------------
+ -- 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.
+
+ -- Alternative solutions include:
+
+ -- 1. Change the PC saved in the system-dependent Context
+ -- parameter to point to code that raises the exception.
+ -- Normal return from this handler will then raise
+ -- the exception after the mask and other system state has
+ -- been restored (see example below).
+ -- 2. Use siglongjmp()/sigsetjmp() to implement exceptions.
+ -- 3. Unmask the signal in the Abortion_Signal exception handler
+ -- (in the RTS).
+
+ -- Note that with the new exception mechanism, it is not correct to
+ -- simply "raise" an exception from a signal handler, that's why we
+ -- use Raise_From_Signal_Handler
+
+ procedure Abort_Handler
+ (signo : Signal;
+ context : sigcontext)
+ is
+ Self_Id : Task_ID := Self;
+ Result : Interfaces.C.int;
+ Old_Set : aliased sigset_t;
+
+ function To_Machine_State_Ptr is new
+ Unchecked_Conversion (Address, Machine_State_Ptr);
+
+ -- These are not directly visible
+
+ procedure Raise_From_Signal_Handler
+ (E : Ada.Exceptions.Exception_Id;
+ M : System.Address);
+ pragma Import
+ (Ada, Raise_From_Signal_Handler,
+ "ada__exceptions__raise_from_signal_handler");
+ pragma No_Return (Raise_From_Signal_Handler);
+
+ mstate : Machine_State_Ptr;
+ message : aliased constant String := "" & ASCII.Nul;
+ -- a null terminated String.
+
+ begin
+ if Self_Id.Deferral_Level = 0
+ and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level
+ and then not Self_Id.Aborting
+ then
+ Self_Id.Aborting := True;
+
+ -- Make sure signals used for RTS internal purpose are unmasked
+
+ Result := pthread_sigmask (SIG_UNBLOCK,
+ Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ mstate := To_Machine_State_Ptr (SSL.Get_Machine_State_Addr.all);
+ for I in mstate.gpr'Range loop
+ mstate.gpr (I) := context.regs.gpr (I);
+ end loop;
+ mstate.nip := context.regs.nip;
+ mstate.msr := context.regs.msr;
+ mstate.orig_gpr3 := context.regs.orig_gpr3;
+ mstate.ctr := context.regs.ctr;
+ mstate.link := context.regs.link;
+ mstate.xer := context.regs.xer;
+ mstate.ccr := context.regs.ccr;
+ mstate.mq := context.regs.mq;
+ mstate.trap := context.regs.trap;
+ mstate.dar := context.regs.dar;
+ mstate.dsisr := context.regs.dsisr;
+ mstate.result := context.regs.result;
+
+ Raise_From_Signal_Handler
+ (Standard'Abort_Signal'Identity, message'Address);
+ end if;
+ end Abort_Handler;
+
+ -------------------
+ -- Stack_Guard --
+ -------------------
+
+ -- The underlying thread system extends the memory (up to 2MB) when
+ -- needed.
+
+ procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ 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 is
+ Result : System.Address;
+
+ begin
+ Result := pthread_getspecific (ATCB_Key);
+ pragma Assert (Result /= System.Null_Address);
+ return To_Task_ID (Result);
+ end 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 All_Tasks_Lock, Memory_Lock...)
+ -- used in RTS is initialized before any status change of RTS.
+ -- Therefore rasing Storage_Error in the following routines
+ -- should be able to be handled safely.
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : access Lock)
+ is
+ Result : Interfaces.C.int;
+ begin
+ if Priority_Ceiling_Emulation then
+ L.Ceiling := Prio;
+ end if;
+
+ Result := pthread_mutex_init (L.L'Access, Mutex_Attr'Access);
+
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ Ada.Exceptions.Raise_Exception (Storage_Error'Identity,
+ "Failed to allocate a lock");
+ end if;
+ end Initialize_Lock;
+
+ procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_init (L, Mutex_Attr'Access);
+
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : 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 : 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 : access Lock; Ceiling_Violation : out Boolean) is
+ Result : Interfaces.C.int;
+
+ begin
+ if Priority_Ceiling_Emulation then
+ declare
+ Self_ID : constant Task_ID := Self;
+ begin
+ if Self_ID.Common.LL.Active_Priority > L.Ceiling then
+ Ceiling_Violation := True;
+ return;
+ end if;
+ L.Saved_Priority := Self_ID.Common.LL.Active_Priority;
+ if Self_ID.Common.LL.Active_Priority < L.Ceiling then
+ Self_ID.Common.LL.Active_Priority := L.Ceiling;
+ end if;
+ Result := pthread_mutex_lock (L.L'Access);
+ pragma Assert (Result = 0);
+ Ceiling_Violation := False;
+ end;
+ else
+ Result := pthread_mutex_lock (L.L'Access);
+ Ceiling_Violation := Result = EINVAL;
+ -- assumes the cause of EINVAL is a priority ceiling violation
+ pragma Assert (Result = 0 or else Result = EINVAL);
+ end if;
+ end Write_Lock;
+
+ procedure Write_Lock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (L);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ Write_Lock (L, Ceiling_Violation);
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : access Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ if Priority_Ceiling_Emulation then
+ declare
+ Self_ID : constant Task_ID := Self;
+ begin
+ Result := pthread_mutex_unlock (L.L'Access);
+ pragma Assert (Result = 0);
+ if Self_ID.Common.LL.Active_Priority > L.Saved_Priority then
+ Self_ID.Common.LL.Active_Priority := L.Saved_Priority;
+ end if;
+ end;
+ else
+ Result := pthread_mutex_unlock (L.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+ end Unlock;
+
+ procedure Unlock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+ -- Beware of any changes to this that might
+ -- require access to the ATCB after the mutex is unlocked.
+ -- This is the last operation performed by a task
+ -- before it allows its ATCB to be deallocated, so it
+ -- MUST NOT refer to the ATCB.
+
+ begin
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ -------------
+ -- Sleep --
+ -------------
+
+ procedure Sleep (Self_ID : Task_ID;
+ Reason : System.Tasking.Task_States) is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Self_ID = Self);
+ Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
+ 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
+ Check_Time : constant Duration := Monotonic_Clock;
+ 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;
+ else
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+ end if;
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ or else Self_ID.Pending_Priority_Change;
+
+ Result := pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
+ Request'Access);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ 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
+ Check_Time : constant Duration := Monotonic_Clock;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+ begin
+
+ -- Only the little window between deferring abort and
+ -- locking Self_ID is the reason we need to
+ -- check for pending abort and priority change below! :(
+
+ SSL.Abort_Defer.all;
+ Write_Lock (Self_ID);
+
+ if Mode = Relative then
+ Abs_Time := Time + Check_Time;
+ else
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+ end if;
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+ Self_ID.Common.State := Delay_Sleep;
+
+ loop
+ if Self_ID.Pending_Priority_Change then
+ Self_ID.Pending_Priority_Change := False;
+ Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
+ Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
+ end if;
+
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access, Request'Access);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ pragma Assert (Result = 0 or else
+ Result = ETIMEDOUT or else
+ Result = EINTR);
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ end if;
+
+ Unlock (Self_ID);
+ Result := sched_yield;
+ SSL.Abort_Undefer.all;
+ end Timed_Delay;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ TV : aliased struct_timeval;
+ Result : Interfaces.C.int;
+
+ begin
+ Result := gettimeofday (TV'Access, System.Null_Address);
+ pragma Assert (Result = 0);
+ return To_Duration (TV);
+ 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
+ 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;
+
+ 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
+ Result : Interfaces.C.int;
+ Param : aliased struct_sched_param;
+
+ begin
+ T.Common.Current_Priority := Prio;
+
+ if Priority_Ceiling_Emulation then
+ if T.Common.LL.Active_Priority < Prio then
+ T.Common.LL.Active_Priority := Prio;
+ end if;
+ end if;
+
+ -- Priorities are in range 1 .. 99 on GNU/Linux, so we map
+ -- map 0 .. 31 to 1 .. 32
+
+ Param.sched_priority := Interfaces.C.int (Prio) + 1;
+
+ if Time_Slice_Val > 0 then
+ Result := pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_RR, Param'Access);
+
+ elsif FIFO_Within_Priorities 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 or else Result = EPERM);
+ 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
+ Result : Interfaces.C.int;
+
+ begin
+ Self_ID.Common.LL.Thread := pthread_self;
+
+ Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID));
+ pragma Assert (Result = 0);
+
+ Lock_All_Tasks_List;
+ for I in Known_Tasks'Range loop
+ if Known_Tasks (I) = null then
+ Known_Tasks (I) := Self_ID;
+ Self_ID.Known_Tasks_Index := I;
+ exit;
+ end if;
+ end loop;
+ Unlock_All_Tasks_List;
+ end Enter_Task;
+
+ --------------
+ -- New_ATCB --
+ --------------
+
+ function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
+ begin
+ return new Ada_Task_Control_Block (Entry_Num);
+ end New_ATCB;
+
+ --------------------
+ -- Initialize_TCB --
+ --------------------
+
+ procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
+ Result : Interfaces.C.int;
+
+ 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);
+
+ Self_ID.Common.LL.Thread := To_pthread_t (-1);
+
+ Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
+ Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
+ Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = 0 then
+ Succeeded := True;
+ else
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ 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;
+ Result : Interfaces.C.int;
+
+ function Thread_Body_Access is new
+ Unchecked_Conversion (System.Address, Thread_Body);
+
+ begin
+ Result := pthread_attr_init (Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 or else Stack_Size > Max_Stack_Size then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_attr_setdetachstate
+ (Attributes'Access, PTHREAD_CREATE_DETACHED);
+ 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'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);
+
+ Set_Priority (T, Priority);
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_ID) is
+ Result : Interfaces.C.int;
+ Tmp : Task_ID := T;
+
+ procedure Free is new
+ Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
+
+ begin
+ Result := pthread_mutex_destroy (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ 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);
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ pthread_exit (System.Null_Address);
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_kill (T.Common.LL.Thread,
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt));
+ pragma Assert (Result = 0);
+ end Abort_Task;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy versions. The only currently working versions is for solaris
+ -- (native).
+
+ function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ begin
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ 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_All_Tasks_List --
+ -------------------------
+
+ procedure Lock_All_Tasks_List is
+ begin
+ Write_Lock (All_Tasks_L'Access);
+ end Lock_All_Tasks_List;
+
+ ---------------------------
+ -- Unlock_All_Tasks_List --
+ ---------------------------
+
+ procedure Unlock_All_Tasks_List is
+ begin
+ Unlock (All_Tasks_L'Access);
+ end Unlock_All_Tasks_List;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ if T.Common.LL.Thread /= Thread_Self then
+ return pthread_kill (T.Common.LL.Thread, SIGSTOP) = 0;
+ else
+ return True;
+ end if;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ if T.Common.LL.Thread /= Thread_Self then
+ return pthread_kill (T.Common.LL.Thread, SIGCONT) = 0;
+ else
+ return True;
+ end if;
+ end Resume_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;
+
+ begin
+ Environment_Task_ID := Environment_Task;
+
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
+ -- Initialize the lock used to synchronize chain of all ATCBs.
+
+ Enter_Task (Environment_Task);
+
+ -- Install the abort-signal handler
+
+ 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 (Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end Initialize;
+
+begin
+ declare
+ Result : Interfaces.C.int;
+ begin
+ -- Mask Environment task for all signals. The original mask of the
+ -- Environment task will be recovered by Interrupt_Server task
+ -- during the elaboration of s-interr.adb.
+
+ System.Interrupt_Management.Operations.Set_Interrupt_Mask
+ (System.Interrupt_Management.Operations.All_Tasks_Mask'Access);
+
+ -- 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;
+
+ Result := pthread_key_create (ATCB_Key'Access, null);
+ pragma Assert (Result = 0);
+ end;
+
+end System.Task_Primitives.Operations;
--- gcc/ada/5josinte.adb.ppcada Thu Jan 31 22:18:02 2002
+++ gcc/ada/5josinte.adb Thu Jan 31 20:31:39 2002
@@ -0,0 +1,130 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1991-2001 Florida State University --
+-- --
+-- 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a GNU/LinuxThreads, Solaris pthread and HP-UX pthread version
+-- of this package.
+
+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.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+with Interfaces.C; use Interfaces.C;
+package body System.OS_Interface is
+
+ --------------------
+ -- Get_Stack_Base --
+ --------------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ -----------------
+ -- 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;
+
+ function To_Duration (TV : struct_timeval) return Duration is
+ begin
+ return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
+ 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;
+
+ ----------------
+ -- To_Timeval --
+ ----------------
+
+ function To_Timeval (D : Duration) return struct_timeval 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 struct_timeval'
+ (tv_sec => S, tv_usec => time_t (Long_Long_Integer (F * 10#1#E6)));
+ end To_Timeval;
+
+end System.OS_Interface;