diff options
Diffstat (limited to 'gcc47-ada.patch')
| -rw-r--r-- | gcc47-ada.patch | 3269 |
1 files changed, 3269 insertions, 0 deletions
diff --git a/gcc47-ada.patch b/gcc47-ada.patch new file mode 100644 index 0000000..ad67a4a --- /dev/null +++ b/gcc47-ada.patch @@ -0,0 +1,3269 @@ +--- origsrc/gcc-4.7.2/gcc/ada//a-intnam-cygwin.ads 1970-01-01 00:00:00.000000000 +0000 ++++ src/gcc-4.7.2/gcc/ada//a-intnam-cygwin.ads 2012-11-01 21:17:31.000000000 +0000 +@@ -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; +--- origsrc/gcc-4.7.2/gcc/ada//gcc-interface/Makefile.in 2012-11-02 15:16:49.765625000 +0000 ++++ src/gcc-4.7.2/gcc/ada//gcc-interface/Makefile.in 2012-11-01 21:17:31.000000000 +0000 +@@ -191,6 +191,13 @@ TARGET_ADA_SRCS = + # 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)) +@@ -1583,6 +1590,12 @@ ifeq ($(strip $(filter-out avr none powe + endif + + ifeq ($(strip $(filter-out cygwin% mingw32% pe,$(osys))),) ++ # 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 +@@ -1651,24 +1664,24 @@ ifeq ($(strip $(filter-out cygwin% mingw + 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 +@@ -1677,7 +1690,14 @@ ifeq ($(strip $(filter-out cygwin% mingw + s-win32.o s-winext.o g-regist.o g-sse.o g-ssvety.o + EXTRA_GNATRTL_TASKING_OBJS = a-exetim.o + +- 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. +@@ -1687,10 +1707,11 @@ ifeq ($(strip $(filter-out cygwin% mingw + 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 +@@ -2425,7 +2446,7 @@ gnatlink-re: ../stamp-tools link.o targe + 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. +@@ -2472,6 +2493,46 @@ install-gnatlib: ../stamp-gnatlib-$(RTSD + 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) +@@ -2672,20 +2733,20 @@ gnatlib-shared-win32: + 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) \ +--- origsrc/gcc-4.7.2/gcc/ada//gsocket.h 2012-11-02 15:16:49.781250000 +0000 ++++ src/gcc-4.7.2/gcc/ada//gsocket.h 2012-11-01 21:17:31.000000000 +0000 +@@ -204,7 +204,8 @@ + #endif + + #if defined (_AIX) || defined (__FreeBSD__) || defined (__hpux__) || \ +- defined (__osf__) || defined (_WIN32) || defined (__APPLE__) ++ defined (__osf__) || defined (_WIN32) || defined (__APPLE__) || \ ++ defined (__CYGWIN__) + # define HAVE_THREAD_SAFE_GETxxxBYyyy 1 + + #elif defined (sgi) || defined (linux) || defined (__GLIBC__) || \ +--- origsrc/gcc-4.7.2/gcc/ada//indepsw-cygwin.adb 1970-01-01 00:00:00.000000000 +0000 ++++ src/gcc-4.7.2/gcc/ada//indepsw-cygwin.adb 2012-11-01 21:17:31.000000000 +0000 +@@ -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; +--- origsrc/gcc-4.7.2/gcc/ada//initialize.c 2012-11-02 15:16:50.031250000 +0000 ++++ src/gcc-4.7.2/gcc/ada//initialize.c 2012-11-01 21:17:31.000000000 +0000 +@@ -348,6 +348,40 @@ __gnat_initialize (void *eh ATTRIBUTE_UN + __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 +--- origsrc/gcc-4.7.2/gcc/ada//mlib-tgt-specific-cygwin.adb 1970-01-01 00:00:00.000000000 +0000 ++++ src/gcc-4.7.2/gcc/ada//mlib-tgt-specific-cygwin.adb 2012-11-01 21:17:31.000000000 +0000 +@@ -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; +--- origsrc/gcc-4.7.2/gcc/ada//s-gloloc-cygwin.adb 1970-01-01 00:00:00.000000000 +0000 ++++ src/gcc-4.7.2/gcc/ada//s-gloloc-cygwin.adb 2012-11-01 21:17:31.000000000 +0000 +@@ -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; +--- origsrc/gcc-4.7.2/gcc/ada//s-osinte-cygwin.ads 1970-01-01 00:00:00.000000000 +0000 ++++ src/gcc-4.7.2/gcc/ada//s-osinte-cygwin.ads 2012-11-01 21:17:31.000000000 +0000 +@@ -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; +--- origsrc/gcc-4.7.2/gcc/ada//s-taprop-cygwin.adb 1970-01-01 00:00:00.000000000 +0000 ++++ src/gcc-4.7.2/gcc/ada//s-taprop-cygwin.adb 2012-11-01 21:17:31.000000000 +0000 +@@ -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; +--- origsrc/gcc-4.7.2/gcc/ada//sysdep.c 2012-11-02 15:16:50.062500000 +0000 ++++ src/gcc-4.7.2/gcc/ada//sysdep.c 2012-11-02 15:50:59.968750000 +0000 +@@ -311,7 +311,7 @@ getc_immediate_common (FILE *stream, + { + #if defined (linux) || defined (sun) || defined (sgi) \ + || (defined (__osf__) && ! defined (__alpha_vxworks)) \ +- || 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__) +@@ -592,6 +592,18 @@ rts_get_nShowCmd (void) + } + + #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. */ +--- origsrc/gcc-4.7.2/gcc/ada//system-cygwin.ads 1970-01-01 00:00:00.000000000 +0000 ++++ src/gcc-4.7.2/gcc/ada//system-cygwin.ads 2012-11-01 21:17:31.000000000 +0000 +@@ -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; |