Befator-Inc-Firmen-Netzwerk/MSYS2-packages
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases 1 Wiki Activity
Files
cb8564b6771e2dbcbb07fa81ab1dcae109ac3cfd
MSYS2-packages/gcc/001-4.7-ada.patch
Alexpux 7eb7c86128 gcc: Rebase patches. Add some fixes.
2014-11-04 00:43:43 +03:00

3280 lines
112 KiB
Diff
Raw Blame History

diff -Naur gcc-4.9.2-orig/gcc/ada/a-intnam-cygwin.ads gcc-4.9.2/gcc/ada/a-intnam-cygwin.ads
--- gcc-4.9.2-orig/gcc/ada/a-intnam-cygwin.ads 1970-01-01 03:00:00.000000000 +0300
+++ gcc-4.9.2/gcc/ada/a-intnam-cygwin.ads 2014-11-03 23:19:36.779800000 +0300
@@ -0,0 +1,170 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2011, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Cygwin version of this package but really it's a copy of the
+-- Linux version, so the below comments are probably irrelevant:
+
+-- The following signals are reserved by the run time (FSU threads):
+
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
+-- SIGALRM, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL
+
+-- The following signals are reserved by the run time (LinuxThreads):
+
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
+-- SIGUSR1, SIGUSR2, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL
+
+-- The pragma Unreserve_All_Interrupts affects the following signal(s):
+
+-- SIGINT: made available for Ada handler
+
+-- This target-dependent package spec contains names of interrupts
+-- supported by the local system.
+
+with System.OS_Interface;
+-- used for names of interrupts
+
+package Ada.Interrupts.Names is
+
+ -- All identifiers in this unit are implementation defined
+
+ pragma Implementation_Defined;
+
+ -- Beware that the mapping of names to signals may be many-to-one. There
+ -- may be aliases. Also, for all signal names that are not supported on the
+ -- current system the value of the corresponding constant will be zero.
+
+ SIGHUP : constant Interrupt_ID :=
+ System.OS_Interface.SIGHUP; -- hangup
+
+ SIGINT : constant Interrupt_ID :=
+ System.OS_Interface.SIGINT; -- interrupt (rubout)
+
+ SIGQUIT : constant Interrupt_ID :=
+ System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
+
+ SIGILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+
+ SIGTRAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTRAP; -- trace trap (not reset)
+
+ SIGIOT : constant Interrupt_ID :=
+ System.OS_Interface.SIGIOT; -- IOT instruction
+
+ SIGABRT : constant Interrupt_ID := -- used by abort,
+ System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
+
+ SIGFPE : constant Interrupt_ID :=
+ System.OS_Interface.SIGFPE; -- floating point exception
+
+ SIGKILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
+
+ SIGBUS : constant Interrupt_ID :=
+ System.OS_Interface.SIGBUS; -- bus error
+
+ SIGSEGV : constant Interrupt_ID :=
+ System.OS_Interface.SIGSEGV; -- segmentation violation
+
+ SIGPIPE : constant Interrupt_ID := -- write on a pipe with
+ System.OS_Interface.SIGPIPE; -- no one to read it
+
+ SIGALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGALRM; -- alarm clock
+
+ SIGTERM : constant Interrupt_ID :=
+ System.OS_Interface.SIGTERM; -- software termination signal from kill
+
+ SIGUSR1 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR1; -- user defined signal 1
+
+ SIGUSR2 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR2; -- user defined signal 2
+
+ SIGCLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCLD; -- child status change
+
+ SIGCHLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
+
+ SIGWINCH : constant Interrupt_ID :=
+ System.OS_Interface.SIGWINCH; -- window size change
+
+ SIGURG : constant Interrupt_ID :=
+ System.OS_Interface.SIGURG; -- urgent condition on IO channel
+
+ SIGPOLL : constant Interrupt_ID :=
+ System.OS_Interface.SIGPOLL; -- pollable event occurred
+
+ SIGIO : constant Interrupt_ID := -- input/output possible,
+ System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
+
+ SIGSTOP : constant Interrupt_ID :=
+ System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored)
+
+ SIGTSTP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTSTP; -- user stop requested from tty
+
+ SIGCONT : constant Interrupt_ID :=
+ System.OS_Interface.SIGCONT; -- stopped process has been continued
+
+ SIGTTIN : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTIN; -- background tty read attempted
+
+ SIGTTOU : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTOU; -- background tty write attempted
+
+ SIGVTALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGVTALRM; -- virtual timer expired
+
+ SIGPROF : constant Interrupt_ID :=
+ System.OS_Interface.SIGPROF; -- profiling timer expired
+
+ SIGXCPU : constant Interrupt_ID :=
+ System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
+
+ SIGXFSZ : constant Interrupt_ID :=
+ System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
+
+ SIGUNUSED : constant Interrupt_ID :=
+ System.OS_Interface.SIGUNUSED; -- unused signal
+
+ SIGSTKFLT : constant Interrupt_ID :=
+ System.OS_Interface.SIGSTKFLT; -- stack fault on coprocessor
+
+ SIGLOST : constant Interrupt_ID :=
+ System.OS_Interface.SIGLOST; -- Linux alias for SIGIO
+
+ SIGPWR : constant Interrupt_ID :=
+ System.OS_Interface.SIGPWR; -- Power failure
+
+end Ada.Interrupts.Names;
diff -Naur gcc-4.9.2-orig/gcc/ada/gcc-interface/Makefile.in gcc-4.9.2/gcc/ada/gcc-interface/Makefile.in
--- gcc-4.9.2-orig/gcc/ada/gcc-interface/Makefile.in 2014-05-17 13:13:12.000000000 +0300
+++ gcc-4.9.2/gcc/ada/gcc-interface/Makefile.in 2014-11-03 23:19:36.811000000 +0300
@@ -203,6 +203,13 @@
# Type of tools build we are doing; default is not compiling tools.
TOOLSCASE =
+# Which install goal to use.
+INSTALL_GNATLIB_MAIN = install-gnatlib
+INSTALL_GNATLIB_WIN32 = unused-install-gnatlib
+
+# Set shared lib prefix (lib on all systems but cygwin, which uses cyg)
+LIBGNAT_SHARED_LIB_PREFIX=lib
+
# Multilib handling
MULTISUBDIR =
RTSDIR = rts$(subst /,_,$(MULTISUBDIR))
@@ -1659,6 +1666,12 @@
# Cygwin/Mingw32
ifeq ($(strip $(filter-out cygwin% mingw32% pe,$(target_os))),)
+ # Set target pair suffix for mingw or cygwin
+ W32_TARG=mingw
+ ifneq ($(strip $(filter cygwin%,$(osys))),)
+ W32_TARG=cygwin
+ LIBGNAT_SHARED_LIB_PREFIX=cyg
+ endif
# Cygwin provides a full Posix environment, and so we use the default
# versions of s-memory and g-socthi rather than the Windows-specific
# MinGW versions. Ideally we would use all the default versions for
@@ -1727,24 +1740,24 @@
ifeq ($(strip $(MULTISUBDIR)),/32)
LIBGNAT_TARGET_PAIRS += \
$(X86_TARGET_PAIRS) \
- system.ads<system-mingw.ads
+ system.ads<system-$(W32_TARG).ads
SO_OPTS= -m32 -Wl,-soname,
else
LIBGNAT_TARGET_PAIRS += \
$(X86_64_TARGET_PAIRS) \
- system.ads<system-mingw-x86_64.ads
+ system.ads<system-$(W32_TARG)-x86_64.ads
SO_OPTS = -m64 -Wl,-soname,
endif
else
ifeq ($(strip $(MULTISUBDIR)),/64)
LIBGNAT_TARGET_PAIRS += \
$(X86_64_TARGET_PAIRS) \
- system.ads<system-mingw-x86_64.ads
+ system.ads<system-$(W32_TARG)-x86_64.ads
SO_OPTS = -m64 -Wl,-soname,
else
LIBGNAT_TARGET_PAIRS += \
$(X86_TARGET_PAIRS) \
- system.ads<system-mingw.ads
+ system.ads<system-$(W32_TARG).ads
SO_OPTS = -m32 -Wl,-soname,
endif
endif
@@ -1753,7 +1766,14 @@
s-win32.o s-winext.o g-regist.o g-sse.o g-ssvety.o
EXTRA_GNATRTL_TASKING_OBJS = a-exetim.o
EXTRA_LIBGNAT_SRCS+=mingw32.h
- MISCLIB = -lws2_32
+ # Which install goal to use.
+ INSTALL_GNATLIB_MAIN = unused-install-gnatlib
+ INSTALL_GNATLIB_WIN32 = install-gnatlib
+
+ # Mingw uses winsock-based sockets; cygwin uses POSIX sockets.
+ ifneq ($(strip $(filter-out cygwin%,$(osys))),)
+ MISCLIB = -lwsock32
+ endif
# ??? This will be replaced by gnatlib-shared-dual-win32 when GNAT
# auto-import support for array/record will be done.
@@ -1763,10 +1783,11 @@
endif
TOOLS_TARGET_PAIRS= \
- mlib-tgt-specific.adb<mlib-tgt-specific-mingw.adb \
- indepsw.adb<indepsw-mingw.adb
+ mlib-tgt-specific.adb<mlib-tgt-specific-$(W32_TARG).adb \
+ indepsw.adb<indepsw-$(W32_TARG).adb
GMEM_LIB = gmemlib
+ EH_MECHANISM=-gcc
EXTRA_GNATTOOLS = ../../gnatdll$(exeext)
EXTRA_GNATMAKE_OBJS = mdll.o mdll-utl.o mdll-fil.o
soext = .dll
@@ -2641,7 +2662,7 @@
true; \
fi
-install-gnatlib: ../stamp-gnatlib-$(RTSDIR)
+$(INSTALL_GNATLIB_MAIN): ../stamp-gnatlib-$(RTSDIR)
# Create the directory before deleting it, in case the directory is
# a list of directories (as it may be on VMS). This ensures we are
# deleting the right one.
@@ -2688,6 +2709,46 @@
cd $(DESTDIR)$(ADA_INCLUDE_DIR); $(CHMOD) a-wx *.adb
cd $(DESTDIR)$(ADA_INCLUDE_DIR); $(CHMOD) a-wx *.ads
+$(INSTALL_GNATLIB_WIN32): ../stamp-gnatlib-$(RTSDIR)
+# Create the directory before deleting it, in case the directory is
+# a list of directories (as it may be on VMS). This ensures we are
+# deleting the right one.
+ -$(MKDIR) $(DESTDIR)$(ADA_RTL_OBJ_DIR)
+ -$(MKDIR) $(DESTDIR)$(ADA_INCLUDE_DIR)
+ $(RMDIR) $(DESTDIR)$(ADA_RTL_OBJ_DIR)
+ $(RMDIR) $(DESTDIR)$(ADA_INCLUDE_DIR)
+ -$(MKDIR) $(DESTDIR)$(ADA_RTL_OBJ_DIR)
+ -$(MKDIR) $(DESTDIR)$(ADA_INCLUDE_DIR)
+ for file in $(RTSDIR)/*.ali; do \
+ $(INSTALL_DATA_DATE) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
+ done
+ -$(INSTALL_DATA) $(RTSDIR)/g-trasym$(objext) $(DESTDIR)$(ADA_RTL_OBJ_DIR)
+ -cd $(RTSDIR); for file in *$(arext);do \
+ $(INSTALL_DATA) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
+ $(RANLIB_FOR_TARGET) $(DESTDIR)$(ADA_RTL_OBJ_DIR)/$$file; \
+ done
+ -$(foreach file, $(EXTRA_ADALIB_FILES), \
+ $(INSTALL_DATA_DATE) $(RTSDIR)/$(file) $(DESTDIR)$(ADA_RTL_OBJ_DIR) && \
+ ) true
+# Install the shared libraries, if any, using $(INSTALL) instead
+# of $(INSTALL_DATA). The latter may force a mode inappropriate
+# for shared libraries on some targets, e.g. on HP-UX where the x
+# permission is required. We are win32 here.
+ for file in gnat gnarl; do \
+ if [ -f $(RTSDIR)/$(LIBGNAT_SHARED_LIB_PREFIX)$${file}$(hyphen)$(LIBRARY_VERSION)$(soext) ]; then \
+ $(INSTALL) $(RTSDIR)/$(LIBGNAT_SHARED_LIB_PREFIX)$${file}$(hyphen)$(LIBRARY_VERSION)$(soext) \
+ $(DESTDIR)$(bindir); \
+ $(LN_S) $(bindir)/$(LIBGNAT_SHARED_LIB_PREFIX)$${file}$(hyphen)$(LIBRARY_VERSION)$(soext) \
+ $(DESTDIR)$(ADA_RTL_OBJ_DIR)/lib$${file}$(hyphen)$(LIBRARY_VERSION).dll.a; \
+ fi; \
+ done
+# This copy must be done preserving the date on the original file.
+ for file in $(RTSDIR)/*.ad?; do \
+ $(INSTALL_DATA_DATE) $$file $(DESTDIR)$(ADA_INCLUDE_DIR); \
+ done
+ cd $(DESTDIR)$(ADA_INCLUDE_DIR); $(CHMOD) a-wx *.adb
+ cd $(DESTDIR)$(ADA_INCLUDE_DIR); $(CHMOD) a-wx *.ads
+
../stamp-gnatlib2-$(RTSDIR):
$(RM) $(RTSDIR)/s-*.ali
$(RM) $(RTSDIR)/s-*$(objext)
@@ -2880,20 +2941,20 @@
MULTISUBDIR="$(MULTISUBDIR)" \
THREAD_KIND="$(THREAD_KIND)" \
gnatlib
- $(RM) $(RTSDIR)/libgna*$(soext)
+ $(RM) $(RTSDIR)/$(LIBGNAT_SHARED_LIB_PREFIX)gna*$(soext)
cd $(RTSDIR); `echo "$(GCC_FOR_TARGET)" \
| sed -e 's,\./xgcc,../../xgcc,' -e 's,-B\./,-B../../,'` -shared -shared-libgcc \
$(PICFLAG_FOR_TARGET) \
- -o libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) \
+ -o $(LIBGNAT_SHARED_LIB_PREFIX)gnat$(hyphen)$(LIBRARY_VERSION)$(soext) \
$(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS) \
- $(SO_OPTS)libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) $(MISCLIB)
+ $(SO_OPTS)$(LIBGNAT_SHARED_LIB_PREFIX)gnat$(hyphen)$(LIBRARY_VERSION)$(soext) $(MISCLIB)
cd $(RTSDIR); `echo "$(GCC_FOR_TARGET)" \
| sed -e 's,\./xgcc,../../xgcc,' -e 's,-B\./,-B../../,'` -shared -shared-libgcc \
$(PICFLAG_FOR_TARGET) \
- -o libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \
+ -o $(LIBGNAT_SHARED_LIB_PREFIX)gnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \
$(GNATRTL_TASKING_OBJS) \
- $(SO_OPTS)libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \
- $(THREADSLIB) -Wl,libgnat$(hyphen)$(LIBRARY_VERSION)$(soext)
+ $(SO_OPTS)$(LIBGNAT_SHARED_LIB_PREFIX)gnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \
+ $(THREADSLIB) -Wl,$(LIBGNAT_SHARED_LIB_PREFIX)gnat$(hyphen)$(LIBRARY_VERSION)$(soext)
gnatlib-shared-darwin:
$(MAKE) $(FLAGS_TO_PASS) \
diff -Naur gcc-4.9.2-orig/gcc/ada/gsocket.h gcc-4.9.2/gcc/ada/gsocket.h
--- gcc-4.9.2-orig/gcc/ada/gsocket.h 2014-08-12 22:49:19.000000000 +0300
+++ gcc-4.9.2/gcc/ada/gsocket.h 2014-11-03 23:19:36.826600000 +0300
@@ -204,7 +204,7 @@
#endif
#if defined (_AIX) || defined (__FreeBSD__) || defined (__hpux__) || \
- defined (_WIN32) || defined (__APPLE__)
+ defined (_WIN32) || defined (__APPLE__) || defined (__CYGWIN__)
# define HAVE_THREAD_SAFE_GETxxxBYyyy 1
#elif defined (linux) || defined (__GLIBC__) || \
diff -Naur gcc-4.9.2-orig/gcc/ada/indepsw-cygwin.adb gcc-4.9.2/gcc/ada/indepsw-cygwin.adb
--- gcc-4.9.2-orig/gcc/ada/indepsw-cygwin.adb 1970-01-01 03:00:00.000000000 +0300
+++ gcc-4.9.2/gcc/ada/indepsw-cygwin.adb 2014-11-03 23:19:36.826600000 +0300
@@ -0,0 +1,67 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- I N D E P S W --
+-- --
+-- B o d y --
+-- (Windows version) --
+-- --
+-- Copyright (C) 2009 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Windows version
+
+package body Indepsw is
+
+ Map_Switch : aliased constant String := "-Wl,-Map,";
+
+ -------------
+ -- Convert --
+ -------------
+
+ procedure Convert
+ (Switch : Switch_Kind;
+ Argument : String;
+ To : out String_List_Access)
+ is
+ begin
+ case Switch is
+ when Map_File =>
+ To := new Argument_List'(1 => new String'(Map_Switch & Argument));
+ end case;
+ end Convert;
+
+ ------------------
+ -- Is_Supported --
+ ------------------
+
+ function Is_Supported (Switch : Switch_Kind) return Boolean is
+ begin
+ case Switch is
+ when Map_File =>
+ return True;
+ end case;
+ end Is_Supported;
+
+end Indepsw;
diff -Naur gcc-4.9.2-orig/gcc/ada/initialize.c gcc-4.9.2/gcc/ada/initialize.c
--- gcc-4.9.2-orig/gcc/ada/initialize.c 2013-02-06 15:01:20.000000000 +0300
+++ gcc-4.9.2/gcc/ada/initialize.c 2014-11-03 23:19:36.842200000 +0300
@@ -297,6 +297,40 @@
__main ();
}
+#elif defined (__CYGWIN__)
+
+/***************************************/
+/* __gnat_initialize (Cygwin Version) */
+/***************************************/
+
+extern void __main (void);
+
+void
+__gnat_initialize (void *eh ATTRIBUTE_UNUSED)
+{
+#ifdef IN_RTS
+ /* We must call __main to run the static ctors, or DW2 EH, amongst
+ other things, will fail. */
+ __main ();
+#endif
+ /* Initialize floating-point coprocessor. This call is needed because
+ the MS libraries default to 64-bit precision instead of 80-bit
+ precision, and we require the full precision for proper operation,
+ given that we have set Max_Digits etc with this in mind */
+ __gnat_init_float ();
+
+ /* Note that we do not activate this for the compiler itself to avoid a
+ bootstrap path problem. Older version of gnatbind will generate a call
+ to __gnat_initialize() without argument. Therefore we cannot use eh in
+ this case. It will be possible to remove the following #ifdef at some
+ point. */
+#ifdef IN_RTS
+ /* Install the Structured Exception handler. */
+ if (eh)
+ __gnat_install_SEH_handler (eh);
+#endif
+}
+
#else
/* For all other versions of GNAT, the initialize routine and handler
diff -Naur gcc-4.9.2-orig/gcc/ada/mlib-tgt-specific-cygwin.adb gcc-4.9.2/gcc/ada/mlib-tgt-specific-cygwin.adb
--- gcc-4.9.2-orig/gcc/ada/mlib-tgt-specific-cygwin.adb 1970-01-01 03:00:00.000000000 +0300
+++ gcc-4.9.2/gcc/ada/mlib-tgt-specific-cygwin.adb 2014-11-03 23:19:36.842200000 +0300
@@ -0,0 +1,162 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . T G T . S P E C I F I C --
+-- (Cygwin Version) --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-2010, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Windows version of the body. Works only with GCC versions
+-- supporting the "-shared" option.
+
+with Opt;
+with Output; use Output;
+
+with MLib.Fil;
+with MLib.Utl;
+
+package body MLib.Tgt.Specific is
+
+ package Files renames MLib.Fil;
+ package Tools renames MLib.Utl;
+
+ -- Non default subprograms
+
+ procedure Build_Dynamic_Library
+ (Ofiles : Argument_List;
+ Options : Argument_List;
+ Interfaces : Argument_List;
+ Lib_Filename : String;
+ Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
+ Driver_Name : Name_Id := No_Name;
+ Lib_Version : String := "";
+ Auto_Init : Boolean := False);
+
+ function DLL_Ext return String;
+
+ function DLL_Prefix return String;
+
+ function Is_Archive_Ext (Ext : String) return Boolean;
+
+ function Library_Major_Minor_Id_Supported return Boolean;
+
+ function PIC_Option return String;
+
+ Shared_Libgcc : aliased String := "-shared-libgcc";
+
+ Shared_Libgcc_Switch : constant Argument_List :=
+ (1 => Shared_Libgcc'Access);
+
+ ---------------------------
+ -- Build_Dynamic_Library --
+ ---------------------------
+
+ procedure Build_Dynamic_Library
+ (Ofiles : Argument_List;
+ Options : Argument_List;
+ Interfaces : Argument_List;
+ Lib_Filename : String;
+ Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
+ Driver_Name : Name_Id := No_Name;
+ Lib_Version : String := "";
+ Auto_Init : Boolean := False)
+ is
+ pragma Unreferenced (Symbol_Data);
+ pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Lib_Version);
+ pragma Unreferenced (Auto_Init);
+
+ Lib_File : constant String :=
+ Lib_Dir & Directory_Separator &
+ DLL_Prefix & Files.Append_To (Lib_Filename, DLL_Ext);
+
+ -- Start of processing for Build_Dynamic_Library
+
+ begin
+ if Opt.Verbose_Mode then
+ Write_Str ("building relocatable shared library ");
+ Write_Line (Lib_File);
+ end if;
+
+ Tools.Gcc
+ (Output_File => Lib_File,
+ Objects => Ofiles,
+ Options => Shared_Libgcc_Switch,
+ Options_2 => Options,
+ Driver_Name => Driver_Name);
+ end Build_Dynamic_Library;
+
+ -------------
+ -- DLL_Ext --
+ -------------
+
+ function DLL_Ext return String is
+ begin
+ return "dll";
+ end DLL_Ext;
+
+ ----------------
+ -- DLL_Prefix --
+ ----------------
+
+ function DLL_Prefix return String is
+ begin
+ return "cyg";
+ end DLL_Prefix;
+
+ --------------------
+ -- Is_Archive_Ext --
+ --------------------
+
+ function Is_Archive_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".a" or else Ext = ".dll";
+ end Is_Archive_Ext;
+
+ --------------------------------------
+ -- Library_Major_Minor_Id_Supported --
+ --------------------------------------
+
+ function Library_Major_Minor_Id_Supported return Boolean is
+ begin
+ return False;
+ end Library_Major_Minor_Id_Supported;
+
+ ----------------
+ -- PIC_Option --
+ ----------------
+
+ function PIC_Option return String is
+ begin
+ return "";
+ end PIC_Option;
+
+begin
+ Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access;
+ DLL_Ext_Ptr := DLL_Ext'Access;
+ DLL_Prefix_Ptr := DLL_Prefix'Access;
+ Is_Archive_Ext_Ptr := Is_Archive_Ext'Access;
+ PIC_Option_Ptr := PIC_Option'Access;
+ Library_Major_Minor_Id_Supported_Ptr :=
+ Library_Major_Minor_Id_Supported'Access;
+end MLib.Tgt.Specific;
diff -Naur gcc-4.9.2-orig/gcc/ada/s-gloloc-cygwin.adb gcc-4.9.2/gcc/ada/s-gloloc-cygwin.adb
--- gcc-4.9.2-orig/gcc/ada/s-gloloc-cygwin.adb 1970-01-01 03:00:00.000000000 +0300
+++ gcc-4.9.2/gcc/ada/s-gloloc-cygwin.adb 2014-11-03 23:19:36.842200000 +0300
@@ -0,0 +1,107 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . G L O B A L _ L O C K S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1999-2010, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This implementation is specific to NT
+
+with System.OS_Interface;
+with System.Task_Lock;
+with System.Win32;
+
+with Interfaces.C.Strings;
+
+package body System.Global_Locks is
+
+ package TSL renames System.Task_Lock;
+ package OSI renames System.OS_Interface;
+ package ICS renames Interfaces.C.Strings;
+
+ subtype Lock_File_Entry is Win32.HANDLE;
+
+ Last_Lock : Lock_Type := Null_Lock;
+ Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry;
+
+ -----------------
+ -- Create_Lock --
+ -----------------
+
+ procedure Create_Lock (Lock : out Lock_Type; Name : String) is
+ L : Lock_Type;
+
+ begin
+ TSL.Lock;
+ Last_Lock := Last_Lock + 1;
+ L := Last_Lock;
+ TSL.Unlock;
+
+ if L > Lock_Table'Last then
+ raise Lock_Error;
+ end if;
+
+ Lock_Table (L) :=
+ OSI.CreateMutex (null, Win32.FALSE, ICS.New_String (Name));
+ Lock := L;
+ end Create_Lock;
+
+ ------------------
+ -- Acquire_Lock --
+ ------------------
+
+ procedure Acquire_Lock (Lock : in out Lock_Type) is
+ use type Win32.DWORD;
+
+ Res : Win32.DWORD;
+
+ begin
+ Res := OSI.WaitForSingleObject (Lock_Table (Lock), OSI.Wait_Infinite);
+
+ if Res = OSI.WAIT_FAILED then
+ raise Lock_Error;
+ end if;
+ end Acquire_Lock;
+
+ ------------------
+ -- Release_Lock --
+ ------------------
+
+ procedure Release_Lock (Lock : in out Lock_Type) is
+ use type Win32.BOOL;
+
+ Res : Win32.BOOL;
+
+ begin
+ Res := OSI.ReleaseMutex (Lock_Table (Lock));
+
+ if Res = Win32.FALSE then
+ raise Lock_Error;
+ end if;
+ end Release_Lock;
+
+end System.Global_Locks;
diff -Naur gcc-4.9.2-orig/gcc/ada/s-osinte-cygwin.ads gcc-4.9.2/gcc/ada/s-osinte-cygwin.ads
--- gcc-4.9.2-orig/gcc/ada/s-osinte-cygwin.ads 1970-01-01 03:00:00.000000000 +0300
+++ gcc-4.9.2/gcc/ada/s-osinte-cygwin.ads 2014-11-03 23:19:36.842200000 +0300
@@ -0,0 +1,951 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2010, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a GNU/Linux (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
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+with Interfaces.C.Strings;
+with Ada.Unchecked_Conversion;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ 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)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 7; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ 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
+ SIGUSR1 : constant := 10; -- user defined signal 1
+ SIGUSR2 : constant := 12; -- user defined signal 2
+ SIGCLD : constant := 17; -- alias for SIGCHLD
+ SIGCHLD : constant := 17; -- child status change
+ SIGPWR : constant := 30; -- power-fail restart
+ SIGWINCH : constant := 28; -- window size change
+ SIGURG : constant := 23; -- urgent condition on IO channel
+ SIGPOLL : constant := 29; -- pollable event occurred
+ SIGIO : constant := 29; -- I/O now possible (4.2 BSD)
+ SIGLOST : constant := 29; -- File lock lost
+ SIGSTOP : constant := 19; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 20; -- user stop requested from tty
+ SIGCONT : constant := 18; -- stopped process has been continued
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGUNUSED : constant := 31; -- unused signal (GNU/Linux)
+ SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux)
+ 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.
+
+ 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 Machine_State is record
+ eip : unsigned_long;
+ ebx : unsigned_long;
+ esp : unsigned_long;
+ ebp : unsigned_long;
+ esi : unsigned_long;
+ edi : unsigned_long;
+ end record;
+ type Machine_State_Ptr is access all Machine_State;
+
+ SA_SIGINFO : constant := 16#04#;
+
+ 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");
+
+ function sysconf (name : int) return long;
+ pragma Import (C, sysconf);
+
+ SC_CLK_TCK : constant := 2;
+ SC_NPROCESSORS_ONLN : constant := 84;
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ 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;
+
+ 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;
+ pragma Convention (C, Thread_Body);
+
+ function Thread_Body_Access is new
+ Ada.Unchecked_Conversion (System.Address, Thread_Body);
+
+ 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_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");
+
+ 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 --
+ --------------------------
+
+ 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);
+ 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");
+
+ 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");
+
+ -------------------
+ -- Win32 compat --
+ -------------------
+
+ -------------------
+ -- General Types --
+ -------------------
+
+ type DWORD is new Interfaces.C.unsigned_long;
+ type WORD is new Interfaces.C.unsigned_short;
+
+ -- The LARGE_INTEGER type is actually a fixed point type
+ -- that only can represent integers. The reason for this is
+ -- easier conversion to Duration or other fixed point types.
+ -- (See Operations.Clock)
+
+ type LARGE_INTEGER is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0;
+
+ subtype PSZ is Interfaces.C.Strings.chars_ptr;
+ subtype PCHAR is Interfaces.C.Strings.chars_ptr;
+
+ subtype PVOID is System.Address;
+
+ Null_Void : constant PVOID := System.Null_Address;
+
+ type PLONG is access all Interfaces.C.long;
+ type PDWORD is access all DWORD;
+
+ type BOOL is new Boolean;
+ for BOOL'Size use Interfaces.C.unsigned_long'Size;
+
+ -------------------------
+ -- Handles for objects --
+ -------------------------
+
+ type HANDLE is new Interfaces.C.long;
+ type PHANDLE is access all HANDLE;
+
+ subtype Win32_Thread_Id is HANDLE;
+
+ ------------------------
+ -- System Information --
+ ------------------------
+
+ type SYSTEM_INFO is record
+ dwOemId : DWORD;
+ dwPageSize : DWORD;
+ lpMinimumApplicationAddress : PVOID;
+ lpMaximumApplicationAddress : PVOID;
+ dwActiveProcessorMask : DWORD;
+ dwNumberOfProcessors : DWORD;
+ dwProcessorType : DWORD;
+ dwAllocationGranularity : DWORD;
+ dwReserved : DWORD;
+ end record;
+
+ procedure GetSystemInfo (SI : access SYSTEM_INFO);
+ pragma Import (Stdcall, GetSystemInfo, "GetSystemInfo");
+
+ ---------------------
+ -- Time Management --
+ ---------------------
+
+ procedure Sleep (dwMilliseconds : DWORD);
+ pragma Import (Stdcall, Sleep, External_Name => "Sleep");
+
+ type SYSTEMTIME is record
+ wYear : WORD;
+ wMonth : WORD;
+ wDayOfWeek : WORD;
+ wDay : WORD;
+ wHour : WORD;
+ wMinute : WORD;
+ wSecond : WORD;
+ wMilliseconds : WORD;
+ end record;
+
+ procedure GetSystemTime (pSystemTime : access SYSTEMTIME);
+ pragma Import (Stdcall, GetSystemTime, "GetSystemTime");
+
+ procedure GetSystemTimeAsFileTime (lpFileTime : access Long_Long_Integer);
+ pragma Import (Stdcall, GetSystemTimeAsFileTime, "GetSystemTimeAsFileTime");
+
+ function SetSystemTime (pSystemTime : access SYSTEMTIME) return BOOL;
+ pragma Import (Stdcall, SetSystemTime, "SetSystemTime");
+
+ function FileTimeToSystemTime
+ (lpFileTime : access Long_Long_Integer;
+ lpSystemTime : access SYSTEMTIME) return BOOL;
+ pragma Import (Stdcall, FileTimeToSystemTime, "FileTimeToSystemTime");
+
+ function SystemTimeToFileTime
+ (lpSystemTime : access SYSTEMTIME;
+ lpFileTime : access Long_Long_Integer) return BOOL;
+ pragma Import (Stdcall, SystemTimeToFileTime, "SystemTimeToFileTime");
+
+ function FileTimeToLocalFileTime
+ (lpFileTime : access Long_Long_Integer;
+ lpLocalFileTime : access Long_Long_Integer) return BOOL;
+ pragma Import (Stdcall, FileTimeToLocalFileTime, "FileTimeToLocalFileTime");
+
+ function LocalFileTimeToFileTime
+ (lpFileTime : access Long_Long_Integer;
+ lpLocalFileTime : access Long_Long_Integer) return BOOL;
+ pragma Import (Stdcall, LocalFileTimeToFileTime, "LocalFileTimeToFileTime");
+
+ function QueryPerformanceCounter
+ (lpPerformanceCount : access LARGE_INTEGER) return BOOL;
+ pragma Import
+ (Stdcall, QueryPerformanceCounter, "QueryPerformanceCounter");
+
+ function QueryPerformanceFrequency
+ (lpFrequency : access LARGE_INTEGER) return BOOL;
+ pragma Import
+ (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency");
+
+ -------------
+ -- Threads --
+ -------------
+
+-- type Win32_Thread_Body is access
+-- function (arg : System.Address) return System.Address;
+-- pragma Convention (C, Thread_Body);
+
+-- function Win32_Thread_Body_Access is new
+-- Ada.Unchecked_Conversion (System.Address, Thread_Body);
+
+ procedure SwitchToThread;
+ pragma Import (Stdcall, SwitchToThread, "SwitchToThread");
+
+ function GetThreadTimes
+ (hThread : HANDLE;
+ lpCreationTime : access Long_Long_Integer;
+ lpExitTime : access Long_Long_Integer;
+ lpKernelTime : access Long_Long_Integer;
+ lpUserTime : access Long_Long_Integer) return BOOL;
+ pragma Import (Stdcall, GetThreadTimes, "GetThreadTimes");
+
+ -----------------------
+ -- Critical sections --
+ -----------------------
+
+ type CRITICAL_SECTION is private;
+
+ procedure InitializeCriticalSection
+ (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import
+ (Stdcall, InitializeCriticalSection, "InitializeCriticalSection");
+
+ procedure EnterCriticalSection
+ (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection");
+
+ procedure LeaveCriticalSection
+ (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection");
+
+ procedure DeleteCriticalSection
+ (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection");
+
+ -------------------------------------------------------------
+ -- Thread Creation, Activation, Suspension And Termination --
+ -------------------------------------------------------------
+
+ subtype ProcessorId is DWORD;
+
+ type PTHREAD_START_ROUTINE is access function
+ (pThreadParameter : PVOID) return DWORD;
+ pragma Convention (Stdcall, PTHREAD_START_ROUTINE);
+
+ function To_PTHREAD_START_ROUTINE is new
+ Ada.Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE);
+
+ type SECURITY_ATTRIBUTES is record
+ nLength : DWORD;
+ pSecurityDescriptor : PVOID;
+ bInheritHandle : BOOL;
+ end record;
+
+ type PSECURITY_ATTRIBUTES is access all SECURITY_ATTRIBUTES;
+
+ function CreateThread
+ (pThreadAttributes : PSECURITY_ATTRIBUTES;
+ dwStackSize : DWORD;
+ pStartAddress : PTHREAD_START_ROUTINE;
+ pParameter : PVOID;
+ dwCreationFlags : DWORD;
+ pThreadId : PDWORD) return HANDLE;
+ pragma Import (Stdcall, CreateThread, "CreateThread");
+
+ function BeginThreadEx
+ (pThreadAttributes : PSECURITY_ATTRIBUTES;
+ dwStackSize : DWORD;
+ pStartAddress : PTHREAD_START_ROUTINE;
+ pParameter : PVOID;
+ dwCreationFlags : DWORD;
+ pThreadId : PDWORD) return HANDLE;
+ pragma Import (C, BeginThreadEx, "_beginthreadex");
+
+ Debug_Process : constant := 16#00000001#;
+ Debug_Only_This_Process : constant := 16#00000002#;
+ Create_Suspended : constant := 16#00000004#;
+ Detached_Process : constant := 16#00000008#;
+ Create_New_Console : constant := 16#00000010#;
+
+ Create_New_Process_Group : constant := 16#00000200#;
+
+ Create_No_window : constant := 16#08000000#;
+
+ Profile_User : constant := 16#10000000#;
+ Profile_Kernel : constant := 16#20000000#;
+ Profile_Server : constant := 16#40000000#;
+
+ Stack_Size_Param_Is_A_Reservation : constant := 16#00010000#;
+
+ function GetExitCodeThread
+ (hThread : HANDLE;
+ pExitCode : PDWORD) return BOOL;
+ pragma Import (Stdcall, GetExitCodeThread, "GetExitCodeThread");
+
+ function ResumeThread (hThread : HANDLE) return DWORD;
+ pragma Import (Stdcall, ResumeThread, "ResumeThread");
+
+ function SuspendThread (hThread : HANDLE) return DWORD;
+ pragma Import (Stdcall, SuspendThread, "SuspendThread");
+
+ procedure ExitThread (dwExitCode : DWORD);
+ pragma Import (Stdcall, ExitThread, "ExitThread");
+
+ procedure EndThreadEx (dwExitCode : DWORD);
+ pragma Import (C, EndThreadEx, "_endthreadex");
+
+ function TerminateThread
+ (hThread : HANDLE;
+ dwExitCode : DWORD) return BOOL;
+ pragma Import (Stdcall, TerminateThread, "TerminateThread");
+
+ function GetCurrentThread return HANDLE;
+ pragma Import (Stdcall, GetCurrentThread, "GetCurrentThread");
+
+ function GetCurrentProcess return HANDLE;
+ pragma Import (Stdcall, GetCurrentProcess, "GetCurrentProcess");
+
+ function GetCurrentThreadId return DWORD;
+ pragma Import (Stdcall, GetCurrentThreadId, "GetCurrentThreadId");
+
+ function TlsAlloc return DWORD;
+ pragma Import (Stdcall, TlsAlloc, "TlsAlloc");
+
+ function TlsGetValue (dwTlsIndex : DWORD) return PVOID;
+ pragma Import (Stdcall, TlsGetValue, "TlsGetValue");
+
+ function TlsSetValue (dwTlsIndex : DWORD; pTlsValue : PVOID) return BOOL;
+ pragma Import (Stdcall, TlsSetValue, "TlsSetValue");
+
+ function TlsFree (dwTlsIndex : DWORD) return BOOL;
+ pragma Import (Stdcall, TlsFree, "TlsFree");
+
+ TLS_Nothing : constant := DWORD'Last;
+
+ procedure ExitProcess (uExitCode : Interfaces.C.unsigned);
+ pragma Import (Stdcall, ExitProcess, "ExitProcess");
+
+ function WaitForSingleObject
+ (hHandle : HANDLE;
+ dwMilliseconds : DWORD) return DWORD;
+ pragma Import (Stdcall, WaitForSingleObject, "WaitForSingleObject");
+
+ function WaitForSingleObjectEx
+ (hHandle : HANDLE;
+ dwMilliseconds : DWORD;
+ fAlertable : BOOL) return DWORD;
+ pragma Import (Stdcall, WaitForSingleObjectEx, "WaitForSingleObjectEx");
+
+ function SetThreadIdealProcessor
+ (hThread : HANDLE;
+ dwIdealProcessor : ProcessorId) return DWORD;
+ pragma Import (Stdcall, SetThreadIdealProcessor, "SetThreadIdealProcessor");
+
+ Wait_Infinite : constant := DWORD'Last;
+ WAIT_TIMEOUT : constant := 16#0000_0102#;
+ WAIT_FAILED : constant := 16#FFFF_FFFF#;
+
+ ------------------------------------
+ -- Semaphores, Events and Mutexes --
+ ------------------------------------
+
+ function CloseHandle (hObject : HANDLE) return BOOL;
+ pragma Import (Stdcall, CloseHandle, "CloseHandle");
+
+ function CreateSemaphore
+ (pSemaphoreAttributes : PSECURITY_ATTRIBUTES;
+ lInitialCount : Interfaces.C.long;
+ lMaximumCount : Interfaces.C.long;
+ pName : PSZ) return HANDLE;
+ pragma Import (Stdcall, CreateSemaphore, "CreateSemaphoreA");
+
+ function OpenSemaphore
+ (dwDesiredAccess : DWORD;
+ bInheritHandle : BOOL;
+ pName : PSZ) return HANDLE;
+ pragma Import (Stdcall, OpenSemaphore, "OpenSemaphoreA");
+
+ function ReleaseSemaphore
+ (hSemaphore : HANDLE;
+ lReleaseCount : Interfaces.C.long;
+ pPreviousCount : PLONG) return BOOL;
+ pragma Import (Stdcall, ReleaseSemaphore, "ReleaseSemaphore");
+
+ function CreateEvent
+ (pEventAttributes : PSECURITY_ATTRIBUTES;
+ bManualReset : BOOL;
+ bInitialState : BOOL;
+ pName : PSZ) return HANDLE;
+ pragma Import (Stdcall, CreateEvent, "CreateEventA");
+
+ function OpenEvent
+ (dwDesiredAccess : DWORD;
+ bInheritHandle : BOOL;
+ pName : PSZ) return HANDLE;
+ pragma Import (Stdcall, OpenEvent, "OpenEventA");
+
+ function SetEvent (hEvent : HANDLE) return BOOL;
+ pragma Import (Stdcall, SetEvent, "SetEvent");
+
+ function ResetEvent (hEvent : HANDLE) return BOOL;
+ pragma Import (Stdcall, ResetEvent, "ResetEvent");
+
+ function PulseEvent (hEvent : HANDLE) return BOOL;
+ pragma Import (Stdcall, PulseEvent, "PulseEvent");
+
+ function CreateMutex
+ (pMutexAttributes : PSECURITY_ATTRIBUTES;
+ bInitialOwner : BOOL;
+ pName : PSZ) return HANDLE;
+ pragma Import (Stdcall, CreateMutex, "CreateMutexA");
+
+ function OpenMutex
+ (dwDesiredAccess : DWORD;
+ bInheritHandle : BOOL;
+ pName : PSZ) return HANDLE;
+ pragma Import (Stdcall, OpenMutex, "OpenMutexA");
+
+ function ReleaseMutex (hMutex : HANDLE) return BOOL;
+ pragma Import (Stdcall, ReleaseMutex, "ReleaseMutex");
+
+ ---------------------------------------------------
+ -- Accessing properties of Threads and Processes --
+ ---------------------------------------------------
+
+ -----------------
+ -- Priorities --
+ -----------------
+
+ function SetThreadPriority
+ (hThread : HANDLE;
+ nPriority : Interfaces.C.int) return BOOL;
+ pragma Import (Stdcall, SetThreadPriority, "SetThreadPriority");
+
+ function GetThreadPriority (hThread : HANDLE) return Interfaces.C.int;
+ pragma Import (Stdcall, GetThreadPriority, "GetThreadPriority");
+
+ function SetPriorityClass
+ (hProcess : HANDLE;
+ dwPriorityClass : DWORD) return BOOL;
+ pragma Import (Stdcall, SetPriorityClass, "SetPriorityClass");
+
+ procedure SetThreadPriorityBoost
+ (hThread : HANDLE;
+ DisablePriorityBoost : BOOL);
+ pragma Import (Stdcall, SetThreadPriorityBoost, "SetThreadPriorityBoost");
+
+ Normal_Priority_Class : constant := 16#00000020#;
+ Idle_Priority_Class : constant := 16#00000040#;
+ High_Priority_Class : constant := 16#00000080#;
+ Realtime_Priority_Class : constant := 16#00000100#;
+
+ Thread_Priority_Idle : constant := -15;
+ Thread_Priority_Lowest : constant := -2;
+ Thread_Priority_Below_Normal : constant := -1;
+ Thread_Priority_Normal : constant := 0;
+ Thread_Priority_Above_Normal : constant := 1;
+ Thread_Priority_Highest : constant := 2;
+ Thread_Priority_Time_Critical : constant := 15;
+ Thread_Priority_Error_Return : constant := Interfaces.C.long'Last;
+
+ function GetLastError return DWORD;
+ pragma Import (Stdcall, GetLastError, "GetLastError");
+
+private
+
+ type sigset_t is array (0 .. 127) of unsigned_char;
+ pragma Convention (C, sigset_t);
+ for sigset_t'Alignment use unsigned_long'Alignment;
+
+ 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, 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 struct_pthread_fast_lock is record
+ status : long;
+ spinlock : int;
+ end record;
+ pragma Convention (C, struct_pthread_fast_lock);
+
+ type pthread_mutex_t is record
+ m_reserved : int;
+ m_count : int;
+ m_owner : System.Address;
+ m_kind : int;
+ m_lock : struct_pthread_fast_lock;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+ type pthread_cond_t is array (0 .. 47) of unsigned_char;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new unsigned;
+
+ -------------------
+ -- Win32 private --
+ -------------------
+
+ type CRITICAL_SECTION is record
+ DebugInfo : System.Address;
+ -- The following three fields control entering and
+ -- exiting the critical section for the resource
+ LockCount : Long_Integer;
+ RecursionCount : Long_Integer;
+ OwningThread : HANDLE;
+ LockSemaphore : HANDLE;
+ Reserved : DWORD;
+ end record;
+
+end System.OS_Interface;
diff -Naur gcc-4.9.2-orig/gcc/ada/s-taprop-cygwin.adb gcc-4.9.2/gcc/ada/s-taprop-cygwin.adb
--- gcc-4.9.2-orig/gcc/ada/s-taprop-cygwin.adb 1970-01-01 03:00:00.000000000 +0300
+++ gcc-4.9.2/gcc/ada/s-taprop-cygwin.adb 2014-11-03 23:19:36.857800000 +0300
@@ -0,0 +1,1337 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a GNU/Linux (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 Interfaces.C;
+-- used for int
+-- size_t
+
+with System.Task_Info;
+-- used for Unspecified_Task_Info
+
+with System.Tasking.Debug;
+-- used for Known_Tasks
+
+with System.Interrupt_Management;
+-- used for Keep_Unmasked
+-- Abort_Task_Interrupt
+-- Interrupt_ID
+
+with System.OS_Primitives;
+-- used for Delay_Modes
+
+with System.Soft_Links;
+-- used for Abort_Defer/Undefer
+
+-- 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.
+
+with System.Storage_Elements;
+with System.Stack_Checking.Operations;
+-- Used for Invalidate_Stack_Cache and Notify_Stack_Attributes;
+
+with Ada.Exceptions;
+-- used for Raise_Exception
+-- Raise_From_Signal_Handler
+-- Exception_Id
+
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+
+package body System.Task_Primitives.Operations is
+
+ package SSL renames System.Soft_Links;
+ package SC renames System.Stack_Checking.Operations;
+
+ use System.Tasking.Debug;
+ use System.Tasking;
+ use Interfaces.C;
+ use System.OS_Interface;
+ use System.Parameters;
+ use System.OS_Primitives;
+ use System.Storage_Elements;
+ use System.Task_Info;
+
+ ----------------
+ -- 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
+
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_Id associated with a thread
+
+ 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 be unblocked in all tasks
+
+ -- The followings are internal configuration constants needed
+
+ Next_Serial_Number : Task_Serial_Number := 100;
+ -- We start at 100 (reserve some special values for using in error checks)
+
+ 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");
+
+ -- 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;
+
+ Foreign_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads)
+
+ --------------------
+ -- 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
+
+ ---------------------------------
+ -- 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 --
+ -----------------------
+
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+
+ procedure Abort_Handler (signo : Signal);
+
+ function To_pthread_t is new Ada.Unchecked_Conversion
+ (unsigned_long, System.OS_Interface.pthread_t);
+
+ procedure Get_Stack_Attributes
+ (T : Task_Id;
+ ISP : out System.Address;
+ Size : out Storage_Offset);
+ -- Fill ISP and Size with the Initial Stack Pointer value and the
+ -- thread stack size for task T.
+
+ -------------------
+ -- Abort_Handler --
+ -------------------
+
+ procedure Abort_Handler (signo : Signal) is
+ pragma Unreferenced (signo);
+
+ Self_Id : constant Task_Id := Self;
+ Result : Interfaces.C.int;
+ Old_Set : aliased sigset_t;
+
+ begin
+ if ZCX_By_Default and then GCC_ZCX_Support then
+ return;
+ end if;
+
+ 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'Access,
+ Old_Set'Access);
+ pragma Assert (Result = 0);
+
+ raise Standard'Abort_Signal;
+ end if;
+ end Abort_Handler;
+
+ --------------
+ -- 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;
+
+ -----------------
+ -- Stack_Guard --
+ -----------------
+
+ -- The underlying thread system extends the memory (up to 2MB) when needed
+
+ procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
+ pragma Unreferenced (T);
+ pragma Unreferenced (On);
+ begin
+ null;
+ end Stack_Guard;
+
+ --------------------
+ -- Get_Thread_Id --
+ --------------------
+
+ function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
+ begin
+ return T.Common.LL.Thread;
+ end Get_Thread_Id;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_Id renames Specific.Self;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ -- Note: mutexes and cond_variables needed per-task basis are
+ -- initialized in Initialize_TCB and the Storage_Error is
+ -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
+ -- used in RTS is initialized before any status change of RTS.
+ -- Therefore rasing 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);
+
+ 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
+ Ada.Exceptions.Raise_Exception (Storage_Error'Identity,
+ "Failed to allocate a lock");
+ end if;
+ end Initialize_Lock;
+
+ procedure Initialize_Lock
+ (L : not null access RTS_Lock;
+ Level : Lock_Level)
+ is
+ pragma Unreferenced (Level);
+
+ 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 : not null access Lock) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_destroy (L);
+ 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);
+ Ceiling_Violation := Result = EINVAL;
+
+ -- Assume the cause of EINVAL is a priority ceiling violation
+
+ 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);
+ 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
+ pragma Assert (Self_ID = Self);
+
+ if Single_Lock then
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
+ else
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+ end if;
+
+ -- EINTR is not considered a failure
+
+ pragma Assert (Result = 0 or else Result = EINTR);
+ end Sleep;
+
+ -----------------
+ -- Timed_Sleep --
+ -----------------
+
+ -- This is for use within the run-time system, so abort is
+ -- assumed to be already deferred, and the caller should be
+ -- holding its own ATCB lock.
+
+ procedure Timed_Sleep
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ pragma Unreferenced (Reason);
+
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ Timedout := True;
+ Yielded := False;
+
+ 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;
+
+ if Single_Lock then
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access,
+ Request'Access);
+
+ else
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Request'Access);
+ end if;
+
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+ if Result = 0 or else Result = EINTR then
+
+ -- Somebody may have called Wakeup for us
+
+ Timedout := False;
+ exit;
+ end if;
+
+ pragma Assert (Result = ETIMEDOUT);
+ end loop;
+ end if;
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ -- This is for use in implementing delay statements, so we assume the
+ -- caller is abort-deferred but is holding no locks.
+
+ procedure Timed_Delay
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+
+ Result : Interfaces.C.int;
+ pragma Warnings (Off, Result);
+
+ begin
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
+ 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
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ if Single_Lock then
+ Result := pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access,
+ Request'Access);
+ else
+ Result := pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Request'Access);
+ end if;
+
+ 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
+ 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
+ pragma Unreferenced (Reason);
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_cond_signal (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+ end Wakeup;
+
+ -----------
+ -- Yield --
+ -----------
+
+ procedure Yield (Do_Yield : Boolean := True) is
+ Result : Interfaces.C.int;
+ pragma Unreferenced (Result);
+ begin
+ if Do_Yield then
+ Result := sched_yield;
+ end if;
+ end Yield;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ procedure Set_Priority
+ (T : Task_Id;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ pragma Unreferenced (Loss_Of_Inheritance);
+
+ Result : Interfaces.C.int;
+ Param : aliased struct_sched_param;
+
+ function Get_Policy (Prio : System.Any_Priority) return Character;
+ pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
+ -- Get priority specific dispatching policy
+
+ Priority_Specific_Policy : constant Character := Get_Policy (Prio);
+ -- Upper case first character of the policy name corresponding to the
+ -- task as set by a Priority_Specific_Dispatching pragma.
+
+ begin
+ T.Common.Current_Priority := Prio;
+
+ -- Priorities on Cygwin follow Win32 standards, we use the
+ -- MinGW conversion table.
+
+ Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
+
+ if Dispatching_Policy = 'R'
+ or else Priority_Specific_Policy = 'R'
+ or else Time_Slice_Val > 0
+ then
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_RR, Param'Access);
+
+ elsif Dispatching_Policy = 'F'
+ or else Priority_Specific_Policy = 'F'
+ or else Time_Slice_Val = 0
+ then
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
+
+ else
+ Param.sched_priority := 0;
+ 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;
+
+ --------------------------
+ -- Get_Stack_Attributes --
+ --------------------------
+
+ procedure Get_Stack_Attributes
+ (T : Task_Id;
+ ISP : out System.Address;
+ Size : out Storage_Offset)
+ is
+ function pthread_getattr_np
+ (thread : pthread_t;
+ attr : System.Address) return Interfaces.C.int;
+ pragma Import (C, pthread_getattr_np, "pthread_getattr_np");
+
+ function pthread_attr_getstack
+ (attr : System.Address;
+ base : System.Address;
+ size : System.Address) return Interfaces.C.int;
+ pragma Import (C, pthread_attr_getstack, "pthread_attr_getstack");
+
+ Result : Interfaces.C.int;
+
+ Attributes : aliased pthread_attr_t;
+ Stack_Base : aliased System.Address;
+ Stack_Size : aliased Storage_Offset;
+
+ begin
+ Result :=
+ pthread_getattr_np
+ (T.Common.LL.Thread, Attributes'Address);
+ pragma Assert (Result = 0);
+
+ Result :=
+ pthread_attr_getstack
+ (Attributes'Address, Stack_Base'Address, Stack_Size'Address);
+ pragma Assert (Result = 0);
+
+ Result := pthread_attr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+
+ ISP := Stack_Base + Stack_Size;
+ Size := Stack_Size;
+ end Get_Stack_Attributes;
+
+ ----------------
+ -- Enter_Task --
+ ----------------
+
+ procedure Enter_Task (Self_ID : Task_Id) is
+ begin
+ if Self_ID.Common.Task_Info /= null
+ and then
+ Self_ID.Common.Task_Info.CPU_Affinity = No_CPU
+ then
+ raise Invalid_CPU_Number;
+ end if;
+
+ Self_ID.Common.LL.Thread := pthread_self;
+
+ Specific.Set (Self_ID);
+
+ Lock_RTS;
+
+ for J in Known_Tasks'Range loop
+ if Known_Tasks (J) = null then
+ Known_Tasks (J) := Self_ID;
+ Self_ID.Known_Tasks_Index := J;
+ exit;
+ end if;
+ end loop;
+
+ Unlock_RTS;
+
+ -- Determine where the task stack starts, how large it is, and let the
+ -- stack checking engine know about it.
+
+ declare
+ Initial_SP : System.Address;
+ Stack_Size : Storage_Offset;
+ begin
+ Get_Stack_Attributes (Self_ID, Initial_SP, Stack_Size);
+ System.Stack_Checking.Operations.Notify_Stack_Attributes
+ (Initial_SP, Stack_Size);
+ end;
+ 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;
+
+ -------------------
+ -- 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
+ 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);
+
+ if not Single_Lock then
+ 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;
+ 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
+ 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;
+ 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;
+
+ begin
+ 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_setstacksize
+ (Attributes'Access, Interfaces.C.size_t (Stack_Size));
+ pragma Assert (Result = 0);
+
+ 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;
+
+ -- Handle Task_Info
+
+ if T.Common.Task_Info /= null then
+ if T.Common.Task_Info.CPU_Affinity /= Task_Info.Any_CPU then
+ Result :=
+ pthread_setaffinity_np
+ (T.Common.LL.Thread,
+ CPU_SETSIZE / 8,
+ T.Common.Task_Info.CPU_Affinity'Access);
+ pragma Assert (Result = 0);
+ end if;
+ end if;
+
+ 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;
+ 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;
+ SC.Invalidate_Stack_Cache (T.Common.Compiler_Data.Pri_Stack_Info'Access);
+ Free (Tmp);
+
+ if Is_Self then
+ Specific.Set (null);
+ end if;
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ Specific.Set (null);
+ 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;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (S : in out Suspension_Object) is
+ 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_mutex_init (S.L'Access, Mutex_Attr'Access);
+
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ -- Initialize internal condition variable
+
+ Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
+
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Result := pthread_mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+ end if;
+ end Initialize;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ -- Destroy internal mutex
+
+ Result := pthread_mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ -- Destroy internal condition variable
+
+ Result := pthread_cond_destroy (S.CV'Access);
+ pragma Assert (Result = 0);
+ end Finalize;
+
+ -------------------
+ -- Current_State --
+ -------------------
+
+ function Current_State (S : Suspension_Object) return Boolean is
+ begin
+ -- We do not want to use lock on this read operation. State is marked
+ -- as Atomic so that we ensure that the value retrieved is correct.
+
+ return S.State;
+ end Current_State;
+
+ ---------------
+ -- Set_False --
+ ---------------
+
+ procedure Set_False (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := pthread_mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ S.State := False;
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end Set_False;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := pthread_mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ -- If there is already a task waiting on this suspension object then
+ -- we resume it, leaving the state of the suspension object to False,
+ -- as it is specified in ARM D.10 par. 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;
+ Result := pthread_cond_wait (S.CV'Access, S.L'Access);
+ 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;
+
+ ------------------
+ -- 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;
+
+ --------------------
+ -- 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 be 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_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0);
+
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+
+ Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
+
+ -- Initialize the global RTS lock
+
+ Specific.Initialize (Environment_Task);
+
+ Enter_Task (Environment_Task);
+
+ -- Install the abort-signal handler
+
+ 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 (Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end if;
+ end Initialize;
+
+end System.Task_Primitives.Operations;
diff -Naur gcc-4.9.2-orig/gcc/ada/sysdep.c gcc-4.9.2/gcc/ada/sysdep.c
--- gcc-4.9.2-orig/gcc/ada/sysdep.c 2014-01-20 18:23:37.000000000 +0300
+++ gcc-4.9.2/gcc/ada/sysdep.c 2014-11-03 23:19:36.857800000 +0300
@@ -317,7 +317,7 @@
int waiting)
{
#if defined (linux) || defined (sun) \
- || defined (__CYGWIN32__) || defined (__MACHTEN__) || defined (__hpux__) \
+ || defined (__CYGWIN__) || defined (__MACHTEN__) || defined (__hpux__) \
|| defined (_AIX) || (defined (__svr4__) && defined (i386)) \
|| defined (__Lynx__) || defined (__FreeBSD__) || defined (__OpenBSD__) \
|| defined (__GLIBC__) || defined (__APPLE__)
@@ -598,6 +598,18 @@
}
#endif /* WINNT */
+
+#ifdef __CYGWIN__
+
+#include <malloc.h>
+
+size_t _msize(void *memblock)
+{
+ return (size_t) malloc_usable_size (memblock);
+}
+
+#endif /* __CYGWIN__ */
+
#ifdef VMS
/* This gets around a problem with using the old threads library on VMS 7.0. */
diff -Naur gcc-4.9.2-orig/gcc/ada/system-cygwin.ads gcc-4.9.2/gcc/ada/system-cygwin.ads
--- gcc-4.9.2-orig/gcc/ada/system-cygwin.ads 1970-01-01 03:00:00.000000000 +0300
+++ gcc-4.9.2/gcc/ada/system-cygwin.ads 2014-11-03 23:19:36.857800000 +0300
@@ -0,0 +1,198 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (Cygwin Version) --
+-- --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+ pragma Pure;
+ -- Note that we take advantage of the implementation permission to make
+ -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
+ -- 2005, this is Pure in any case (AI-362).
+
+ type Name is (SYSTEM_NAME_GNAT);
+ System_Name : constant Name := SYSTEM_NAME_GNAT;
+
+ -- System-Dependent Named Numbers
+
+ Min_Int : constant := Long_Long_Integer'First;
+ Max_Int : constant := Long_Long_Integer'Last;
+
+ Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
+ Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1;
+
+ Max_Base_Digits : constant := Long_Long_Float'Digits;
+ Max_Digits : constant := Long_Long_Float'Digits;
+
+ Max_Mantissa : constant := 63;
+ Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
+
+ Tick : constant := 0.01;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ pragma Preelaborable_Initialization (Address);
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := 8;
+ Word_Size : constant := 32;
+ Memory_Size : constant := 2 ** 32;
+
+ -- Address comparison
+
+ function "<" (Left, Right : Address) return Boolean;
+ function "<=" (Left, Right : Address) return Boolean;
+ function ">" (Left, Right : Address) return Boolean;
+ function ">=" (Left, Right : Address) return Boolean;
+ function "=" (Left, Right : Address) return Boolean;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+ pragma Import (Intrinsic, "=");
+
+ -- Other System-Dependent Declarations
+
+ type Bit_Order is (High_Order_First, Low_Order_First);
+ Default_Bit_Order : constant Bit_Order := Low_Order_First;
+ pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 30;
+ Max_Interrupt_Priority : constant Positive := 31;
+
+ subtype Any_Priority is Integer range 0 .. 31;
+ subtype Priority is Any_Priority range 0 .. 30;
+ subtype Interrupt_Priority is Any_Priority range 31 .. 31;
+
+ Default_Priority : constant Priority := 15;
+
+private
+
+ type Address is mod Memory_Size;
+ Null_Address : constant Address := 0;
+
+ --------------------------------------
+ -- System Implementation Parameters --
+ --------------------------------------
+
+ -- These parameters provide information about the target that is used
+ -- by the compiler. They are in the private part of System, where they
+ -- can be accessed using the special circuitry in the Targparm unit
+ -- whose source should be consulted for more detailed descriptions
+ -- of the individual switch values.
+
+ Backend_Divide_Checks : constant Boolean := False;
+ Backend_Overflow_Checks : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
+ Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
+ Exit_Status_Supported : constant Boolean := True;
+ Fractional_Fixed_Ops : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ Preallocated_Stacks : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := True;
+ Stack_Check_Limits : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Always_Compatible_Rep : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := True;
+
+ ---------------------------
+ -- Underlying Priorities --
+ ---------------------------
+
+ -- Important note: this section of the file must come AFTER the
+ -- definition of the system implementation parameters to ensure
+ -- that the value of these parameters is available for analysis
+ -- of the declarations here (using Rtsfind at compile time).
+
+ -- The underlying priorities table provides a generalized mechanism
+ -- for mapping from Ada priorities to system priorities. In some
+ -- cases a 1-1 mapping is not the convenient or optimal choice.
+
+ type Priorities_Mapping is array (Any_Priority) of Integer;
+ pragma Suppress_Initialization (Priorities_Mapping);
+ -- Suppress initialization in case gnat.adc specifies Normalize_Scalars
+
+ Underlying_Priorities : constant Priorities_Mapping :=
+ (Priority'First ..
+ Default_Priority - 8 => -15,
+ Default_Priority - 7 => -7,
+ Default_Priority - 6 => -6,
+ Default_Priority - 5 => -5,
+ Default_Priority - 4 => -4,
+ Default_Priority - 3 => -3,
+ Default_Priority - 2 => -2,
+ Default_Priority - 1 => -1,
+ Default_Priority => 0,
+ Default_Priority + 1 => 1,
+ Default_Priority + 2 => 2,
+ Default_Priority + 3 => 3,
+ Default_Priority + 4 => 4,
+ Default_Priority + 5 => 5,
+ Default_Priority + 6 ..
+ Priority'Last => 6,
+ Interrupt_Priority => 15);
+ -- The default mapping preserves the standard 31 priorities of the Ada
+ -- model, but maps them using compression onto the 7 priority levels
+ -- available in NT and on the 16 priority levels available in 2000/XP.
+
+ -- To replace the default values of the Underlying_Priorities mapping,
+ -- copy this source file into your build directory, edit the file to
+ -- reflect your desired behavior, and recompile using Makefile.adalib
+ -- which can be found under the adalib directory of your gnat installation
+
+ pragma Linker_Options ("-Wl,--stack=0x2000000");
+ -- This is used to change the default stack (32 MB) size for non tasking
+ -- programs. We change this value for GNAT on Windows here because the
+ -- binutils on this platform have switched to a too low value for Ada
+ -- programs. Note that we also set the stack size for tasking programs in
+ -- System.Task_Primitives.Operations.
+
+end System;
Reference in New Issue View Git Blame Copy Permalink