From 6c802906a388f6816ba641f8ec83ef812ffe8fbd Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 20 Nov 2014 12:13:40 +0100 Subject: [PATCH] [multiple changes] 2014-11-20 Pascal Obry * initialize.c (ProcListCS): New extern variable (critical section). (ProcListEvt): New extern variable (handle). (__gnat_initialize)[Win32]: Initialize the ProcListCS critical section object and the ProcListEvt event. * final.c (__gnat_finalize)[Win32]: Properly finalize the ProcListCS critical section and the ProcListEvt event. * adaint.c (ProcListEvt): New Win32 event handle. (EnterCS): New routine to enter the critical section when dealing with child processes chain list. (LeaveCS): As above to exit from the critical section. (SignalListChanged): Routine to signal that the chain process list has been updated. (add_handle): Use EnterCS/LeaveCS, also call SignalListChanged when the handle has been added. (__gnat_win32_remove_handle): Use EnterCS/LeaveCS, also call SignalListChanged if the handle has been found and removed. (remove_handle): Routine removed, implementation merged with the above. (win32_wait): Use EnterCS/LeaveCS for the critical section. Properly copy the PID list locally to ensure that even if the list is updated the local copy remains valid. Add into the hl (handle list) the ProcListEvt handle. This handle is used to signal that a change has been made into the process chain list. This is to ensure that a waiting call can be resumed to take into account new processes. We also make sure that if the handle was not found into the list we start over the wait call. Indeed another concurrent call to win32_wait() could already have handled this process. 2014-11-20 Ed Schonberg * sem_res.adb (Resolve_Actuals): The legality rule concerning the use of class-wide actuals for a non-controlling formal are not rechecked in an instance. 2014-11-20 Pascal Obry * g-dirope.ads: Minor typo fix. 2014-11-20 Hristian Kirtchev * exp_attr.adb (Expand_N_Attribute_Reference, Expand_Update_Attribute): Preserve the tag of a prefix by offering a specific view of the class-wide version of the prefix. From-SVN: r217837 --- gcc/ada/ChangeLog | 45 +++++++++++ gcc/ada/adaint.c | 108 +++++++++++++++++++-------- gcc/ada/adaint.h | 2 +- gcc/ada/exp_attr.adb | 206 +++++++++++++++++++++++++++++++++++++++------------ gcc/ada/final.c | 20 ++++- gcc/ada/g-dirope.ads | 2 +- gcc/ada/initialize.c | 7 ++ gcc/ada/sem_res.adb | 3 + 8 files changed, 310 insertions(+), 83 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c904bde..39c4e09 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,48 @@ +2014-11-20 Pascal Obry + + * initialize.c (ProcListCS): New extern variable (critical section). + (ProcListEvt): New extern variable (handle). + (__gnat_initialize)[Win32]: Initialize the ProcListCS critical + section object and the ProcListEvt event. + * final.c (__gnat_finalize)[Win32]: Properly finalize the + ProcListCS critical section and the ProcListEvt event. + * adaint.c (ProcListEvt): New Win32 event handle. + (EnterCS): New routine to enter the critical section when dealing with + child processes chain list. + (LeaveCS): As above to exit from the critical section. + (SignalListChanged): Routine to signal that the chain process list has + been updated. + (add_handle): Use EnterCS/LeaveCS, also call SignalListChanged when the + handle has been added. + (__gnat_win32_remove_handle): Use EnterCS/LeaveCS, + also call SignalListChanged if the handle has been found and removed. + (remove_handle): Routine removed, implementation merged with the above. + (win32_wait): Use EnterCS/LeaveCS for the critical section. Properly + copy the PID list locally to ensure that even if the list is updated + the local copy remains valid. Add into the hl (handle list) the + ProcListEvt handle. This handle is used to signal that a change has + been made into the process chain list. This is to ensure that a waiting + call can be resumed to take into account new processes. We also make + sure that if the handle was not found into the list we start over + the wait call. Indeed another concurrent call to win32_wait() + could already have handled this process. + +2014-11-20 Ed Schonberg + + * sem_res.adb (Resolve_Actuals): The legality rule concerning + the use of class-wide actuals for a non-controlling formal are + not rechecked in an instance. + +2014-11-20 Pascal Obry + + * g-dirope.ads: Minor typo fix. + +2014-11-20 Hristian Kirtchev + + * exp_attr.adb (Expand_N_Attribute_Reference, + Expand_Update_Attribute): Preserve the tag of a prefix by offering + a specific view of the class-wide version of the prefix. + 2014-11-20 Javier Miranda * sem_ch6.adb (Analyze_Function_Return): For functions returning diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index cd3f11a3..36a1189 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -2311,20 +2311,29 @@ __gnat_number_of_cpus (void) for locking and unlocking tasks since we do not support multiple threads on this configuration (Cert run time on native Windows). */ -static void dummy (void) -{ -} - -void (*Lock_Task) () = &dummy; -void (*Unlock_Task) () = &dummy; +static void EnterCS (void) {} +static void LeaveCS (void) {} +static void SignalListChanged (void) {} #else -#define Lock_Task system__soft_links__lock_task -extern void (*Lock_Task) (void); +CRITICAL_SECTION ProcListCS; +HANDLE ProcListEvt; + +static void EnterCS (void) +{ + EnterCriticalSection(&ProcListCS); +} -#define Unlock_Task system__soft_links__unlock_task -extern void (*Unlock_Task) (void); +static void LeaveCS (void) +{ + LeaveCriticalSection(&ProcListCS); +} + +static void SignalListChanged (void) +{ + SetEvent (ProcListEvt); +} #endif @@ -2335,7 +2344,7 @@ static void add_handle (HANDLE h, int pid) { /* -------------------- critical section -------------------- */ - (*Lock_Task) (); + EnterCS(); if (plist_length == plist_max_length) { @@ -2350,14 +2359,19 @@ add_handle (HANDLE h, int pid) PID_LIST[plist_length] = pid; ++plist_length; - (*Unlock_Task) (); + SignalListChanged(); + LeaveCS(); /* -------------------- critical section -------------------- */ } -static void -remove_handle (HANDLE h, int pid) +int +__gnat_win32_remove_handle (HANDLE h, int pid) { int j; + int found = 0; + + /* -------------------- critical section -------------------- */ + EnterCS(); for (j = 0; j < plist_length; j++) { @@ -2367,21 +2381,18 @@ remove_handle (HANDLE h, int pid) --plist_length; HANDLES_LIST[j] = HANDLES_LIST[plist_length]; PID_LIST[j] = PID_LIST[plist_length]; + found = 1; break; } } -} -void -__gnat_win32_remove_handle (HANDLE h, int pid) -{ + LeaveCS(); /* -------------------- critical section -------------------- */ - (*Lock_Task) (); - remove_handle(h, pid); + if (found) + SignalListChanged(); - (*Unlock_Task) (); - /* -------------------- critical section -------------------- */ + return found; } static void @@ -2466,35 +2477,70 @@ win32_wait (int *status) DWORD exitcode, pid; HANDLE *hl; HANDLE h; + int *pidl; DWORD res; int hl_len; + int found; - /* -------------------- critical section -------------------- */ - (*Lock_Task) (); + START_WAIT: if (plist_length == 0) { errno = ECHILD; - (*Unlock_Task) (); return -1; } + /* -------------------- critical section -------------------- */ + EnterCS(); + hl_len = plist_length; +#ifdef CERT hl = (HANDLE *) xmalloc (sizeof (HANDLE) * hl_len); - memmove (hl, HANDLES_LIST, sizeof (HANDLE) * hl_len); + pidl = (int *) xmalloc (sizeof (int) * hl_len); + memmove (pidl, PID_LIST, sizeof (int) * hl_len); +#else + /* Note that index 0 contains the event hanlde that is signaled when the + process list has changed */ + hl = (HANDLE *) xmalloc (sizeof (HANDLE) * hl_len + 1); + hl[0] = ProcListEvt; + memmove (&hl[1], HANDLES_LIST, sizeof (HANDLE) * hl_len); + pidl = (int *) xmalloc (sizeof (int) * hl_len + 1); + memmove (&pidl[1], PID_LIST, sizeof (int) * hl_len); + hl_len++; +#endif + + LeaveCS(); + /* -------------------- critical section -------------------- */ res = WaitForMultipleObjects (hl_len, hl, FALSE, INFINITE); - h = hl[res - WAIT_OBJECT_0]; + /* if the ProcListEvt has been signaled then the list of processes has been + updated to add or remove a handle, just loop over */ + + if (res - WAIT_OBJECT_0 == 0) + { + free (hl); + free (pidl); + goto START_WAIT; + } + + h = hl[res - WAIT_OBJECT_0]; GetExitCodeProcess (h, &exitcode); - pid = PID_LIST [res - WAIT_OBJECT_0]; - remove_handle (h, -1); + pid = pidl [res - WAIT_OBJECT_0]; + + found = __gnat_win32_remove_handle (h, -1); - (*Unlock_Task) (); - /* -------------------- critical section -------------------- */ free (hl); + free (pidl); + + /* if not found another process waiting has already handled this process */ + + if (!found) + { + goto START_WAIT; + } *status = (int) exitcode; return (int) pid; diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index d2a838e..b0e66cc 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -299,7 +299,7 @@ extern void __gnat_cpu_set (int, size_t, cpu_set_t *); #if defined (_WIN32) /* Interface to delete a handle from internally maintained list of child process handles on Windows */ -extern void +extern int __gnat_win32_remove_handle (HANDLE h, int pid); #endif diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index d2cd8e4..eb5f28f 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1021,6 +1021,9 @@ package body Exp_Attr is Pref : constant Node_Id := Prefix (N); Typ : constant Entity_Id := Etype (Pref); Blk : Node_Id; + CW_Decl : Node_Id; + CW_Temp : Entity_Id; + CW_Typ : Entity_Id; Decls : List_Id; Installed : Boolean; Loc : Source_Ptr; @@ -1338,18 +1341,55 @@ package body Exp_Attr is -- Step 3: Create a constant to capture the value of the prefix at the -- entry point into the loop. - -- Generate: - -- Temp : constant := ; - Temp_Id := Make_Temporary (Loc, 'P'); - Temp_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp_Id, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => Relocate_Node (Pref)); - Append_To (Decls, Temp_Decl); + -- Preserve the tag of the prefix by offering a specific view of the + -- class-wide version of the prefix. + + if Is_Tagged_Type (Typ) then + + -- Generate: + -- CW_Temp : constant Typ'Class := Typ'Class (Pref); + + CW_Temp := Make_Temporary (Loc, 'T'); + CW_Typ := Class_Wide_Type (Typ); + + CW_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => CW_Temp, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (CW_Typ, Loc), + Expression => + Convert_To (CW_Typ, Relocate_Node (Pref))); + Append_To (Decls, CW_Decl); + + -- Generate: + -- Temp : Typ renames Typ (CW_Temp); + + Temp_Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Temp_Id, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Name => + Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc))); + Append_To (Decls, Temp_Decl); + + -- Non-tagged case + + else + CW_Decl := Empty; + + -- Generate: + -- Temp : constant Typ := Pref; + + Temp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (Pref)); + Append_To (Decls, Temp_Decl); + end if; -- Step 4: Analyze all bits @@ -1374,6 +1414,10 @@ package body Exp_Attr is -- the declaration of the constant. else + if Present (CW_Decl) then + Analyze (CW_Decl); + end if; + Analyze (Temp_Decl); end if; @@ -4358,19 +4402,13 @@ package body Exp_Attr is --------- when Attribute_Old => Old : declare - Asn_Stm : Node_Id; + Typ : constant Entity_Id := Etype (N); + CW_Temp : Entity_Id; + CW_Typ : Entity_Id; Subp : Node_Id; Temp : Entity_Id; begin - Temp := Make_Temporary (Loc, 'T', Pref); - - -- Set the entity kind now in order to mark the temporary as a - -- handler of attribute 'Old's prefix. - - Set_Ekind (Temp, E_Constant); - Set_Stores_Attribute_Old_Prefix (Temp); - -- Climb the parent chain looking for subprogram _Postconditions Subp := N; @@ -4395,15 +4433,13 @@ package body Exp_Attr is pragma Assert (Present (Subp)); - -- Generate: - -- Temp : constant := ; + Temp := Make_Temporary (Loc, 'T', Pref); - Asn_Stm := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Etype (N), Loc), - Expression => Pref); + -- Set the entity kind now in order to mark the temporary as a + -- handler of attribute 'Old's prefix. + + Set_Ekind (Temp, E_Constant); + Set_Stores_Attribute_Old_Prefix (Temp); -- Push the scope of the related subprogram where _Postcondition -- resides as this ensures that the object will be analyzed in the @@ -4411,12 +4447,49 @@ package body Exp_Attr is Push_Scope (Scope (Defining_Entity (Subp))); - -- The object declaration is inserted before the body of subprogram - -- _Postconditions. This ensures that any precondition-like actions - -- are still executed before any parameter values are captured and - -- the multiple 'Old occurrences appear in order of declaration. + -- Preserve the tag of the prefix by offering a specific view of the + -- class-wide version of the prefix. + + if Is_Tagged_Type (Typ) then + + -- Generate: + -- CW_Temp : constant Typ'Class := Typ'Class (Pref); + + CW_Temp := Make_Temporary (Loc, 'T'); + CW_Typ := Class_Wide_Type (Typ); + + Insert_Before_And_Analyze (Subp, + Make_Object_Declaration (Loc, + Defining_Identifier => CW_Temp, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (CW_Typ, Loc), + Expression => + Convert_To (CW_Typ, Relocate_Node (Pref)))); + + -- Generate: + -- Temp : Typ renames Typ (CW_Temp); + + Insert_Before_And_Analyze (Subp, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Temp, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Name => + Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc)))); + + -- Non-tagged case + + else + -- Generate: + -- Temp : constant Typ := Pref; + + Insert_Before_And_Analyze (Subp, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (Pref))); + end if; - Insert_Before_And_Analyze (Subp, Asn_Stm); Pop_Scope; -- Ensure that the prefix of attribute 'Old is valid. The check must @@ -7351,30 +7424,65 @@ package body Exp_Attr is -- Local variables - Aggr : constant Node_Id := First (Expressions (N)); - Loc : constant Source_Ptr := Sloc (N); - Pref : constant Node_Id := Prefix (N); - Typ : constant Entity_Id := Etype (Pref); - Assoc : Node_Id; - Comp : Node_Id; - Expr : Node_Id; - Temp : Entity_Id; + Aggr : constant Node_Id := First (Expressions (N)); + Loc : constant Source_Ptr := Sloc (N); + Pref : constant Node_Id := Prefix (N); + Typ : constant Entity_Id := Etype (Pref); + Assoc : Node_Id; + Comp : Node_Id; + CW_Temp : Entity_Id; + CW_Typ : Entity_Id; + Expr : Node_Id; + Temp : Entity_Id; -- Start of processing for Expand_Update_Attribute begin - -- Create the anonymous object that stores the value of the prefix and - -- reflects subsequent changes in value. Generate: + -- Create the anonymous object to store the value of the prefix and + -- capture subsequent changes in value. + + Temp := Make_Temporary (Loc, 'T', Pref); - -- Temp : := Pref; + -- Preserve the tag of the prefix by offering a specific view of the + -- class-wide version of the prefix. - Temp := Make_Temporary (Loc, 'T'); + if Is_Tagged_Type (Typ) then - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => Relocate_Node (Pref))); + -- Generate: + -- CW_Temp : Typ'Class := Typ'Class (Pref); + + CW_Temp := Make_Temporary (Loc, 'T'); + CW_Typ := Class_Wide_Type (Typ); + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => CW_Temp, + Object_Definition => New_Occurrence_Of (CW_Typ, Loc), + Expression => + Convert_To (CW_Typ, Relocate_Node (Pref)))); + + -- Generate: + -- Temp : Typ renames Typ (CW_Temp); + + Insert_Action (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Temp, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Name => + Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc)))); + + -- Non-tagged case + + else + -- Generate: + -- Temp : Typ := Pref; + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (Pref))); + end if; -- Process the update aggregate diff --git a/gcc/ada/final.c b/gcc/ada/final.c index b49b3de..dffc2b2 100644 --- a/gcc/ada/final.c +++ b/gcc/ada/final.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2011, Free Software Foundation, Inc. * + * Copyright (C) 1992-2014, 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- * @@ -40,10 +40,28 @@ extern void __gnat_finalize (void); at all, the intention is that this be replaced by system specific code where finalization is required. */ +#if defined (__MINGW32__) +#include "mingw32.h" +#include + +extern CRITICAL_SECTION ProcListCS; +extern HANDLE ProcListEvt; + +void +__gnat_finalize (void) +{ + /* delete critical section and event handle used for the + processes chain list */ + DeleteCriticalSection(&ProcListCS); + CloseHandle (ProcListEvt); +} + +#else void __gnat_finalize (void) { } +#endif #ifdef __cplusplus } diff --git a/gcc/ada/g-dirope.ads b/gcc/ada/g-dirope.ads index fe02d3f..c3c207f 100644 --- a/gcc/ada/g-dirope.ads +++ b/gcc/ada/g-dirope.ads @@ -175,7 +175,7 @@ package GNAT.Directory_Operations is -- Returns Path with environment variables replaced by the current -- environment variable value. For example, $HOME/mydir will be replaced -- by /home/joe/mydir if $HOME environment variable is set to /home/joe and - -- Mode is UNIX. If an environment variable does not exists the variable + -- Mode is UNIX. If an environment variable does not exist the variable -- will be replaced by the empty string. Two dollar or percent signs are -- replaced by a single dollar/percent sign. Note that a variable must -- start with a letter. diff --git a/gcc/ada/initialize.c b/gcc/ada/initialize.c index 36df501..9426c9e 100644 --- a/gcc/ada/initialize.c +++ b/gcc/ada/initialize.c @@ -74,6 +74,8 @@ extern void __gnat_install_SEH_handler (void *); extern int gnat_argc; extern char **gnat_argv; +extern CRITICAL_SECTION ProcListCS; +extern HANDLE ProcListEvt; #ifdef GNAT_UNICODE_SUPPORT @@ -138,6 +140,11 @@ __gnat_initialize (void *eh ATTRIBUTE_UNUSED) given that we have set Max_Digits etc with this in mind */ __gnat_init_float (); + /* Initialize the critical section and event handle for the win32_wait() + implementation, see adaint.c */ + InitializeCriticalSection (&ProcListCS); + ProcListEvt = CreateEvent (NULL, FALSE, FALSE, NULL); + #ifdef GNAT_UNICODE_SUPPORT /* Set current code page for filenames handling. */ { diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 24628bc..71f480f 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4520,9 +4520,12 @@ package body Sem_Res is Validate_Remote_Access_To_Class_Wide_Type (A); end if; + -- Apply legality rule 3.9.2 (9/1) + if (Is_Class_Wide_Type (A_Typ) or else Is_Dynamically_Tagged (A)) and then not Is_Class_Wide_Type (F_Typ) and then not Is_Controlling_Formal (F) + and then not In_Instance then Error_Msg_N ("class-wide argument not allowed here!", A); -- 2.7.4