--- 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 -- +-- . -- +-- -- +-- 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. -- +-- -- +-- 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 -- +-- . -- +-- -- +-- 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 -- +-- . -- +-- -- +-- 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 -- +-- . -- +-- -- +-- 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, int waiting) { #if defined (linux) || defined (sun) \ - || defined (__CYGWIN32__) || defined (__MACHTEN__) || defined (__hpux__) \ + || defined (__CYGWIN__) || defined (__MACHTEN__) || defined (__hpux__) \ || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ || defined (__Lynx__) || defined (__FreeBSD__) || defined (__OpenBSD__) \ || defined (__GLIBC__) || defined (__APPLE__) @@ -592,6 +592,18 @@ rts_get_nShowCmd (void) } #endif /* WINNT */ + +#ifdef __CYGWIN__ + +#include + +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;