From cff7cd9b1336236660bf486021063e96271cf137 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 27 Jul 2009 15:56:38 +0200 Subject: [PATCH] [multiple changes] 2009-07-27 Robert Dewar * sem_util.adb, sem_util.ads (Kill_Current_Values): Reset Is_Known_Valid 2009-07-27 Javier Miranda * exp_disp.adb (Expand_Dispatching_Call): Reverse previous patch and add some documentation explaining why the SCIL nodes must be generated at that point. 2009-07-27 Olivier Hainque * a-except.adb: Bind to __builtin_longjmp directly. * a-except-2005.ads: Provide direct binding to __builtin_longjmp for sjlj variants. * a-exexpr.adb: Use it. * a-except-xi.adb: Likewise. * raise.c (_gnat_builtin_longjmp): Remove and update comments. * raise.h (_gnat_builtin_longjmp): Remove declaration. From-SVN: r150119 --- gcc/ada/ChangeLog | 20 ++++++++++++++++++++ gcc/ada/a-except-2005.ads | 16 ++++++++++++++++ gcc/ada/a-exexpr.adb | 6 +----- gcc/ada/exp_disp.adb | 25 ++++++++++++++----------- gcc/ada/raise.c | 15 +++++++++------ gcc/ada/sem_util.adb | 28 +++++++++++++++++++++------- gcc/ada/sem_util.ads | 10 +++++----- 7 files changed, 86 insertions(+), 34 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e4efbe33d08..1451d48eaff 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,23 @@ +2009-07-27 Robert Dewar + + * sem_util.adb, sem_util.ads (Kill_Current_Values): Reset Is_Known_Valid + +2009-07-27 Javier Miranda + + * exp_disp.adb (Expand_Dispatching_Call): Reverse previous patch and + add some documentation explaining why the SCIL nodes must be generated + at that point. + +2009-07-27 Olivier Hainque + + * a-except.adb: Bind to __builtin_longjmp directly. + * a-except-2005.ads: Provide direct binding to __builtin_longjmp + for sjlj variants. + * a-exexpr.adb: Use it. + * a-except-xi.adb: Likewise. + * raise.c (_gnat_builtin_longjmp): Remove and update comments. + * raise.h (_gnat_builtin_longjmp): Remove declaration. + 2009-07-27 Ed Schonberg * sem_eval.adb (Compile_Time_Compare): More precise handling of diff --git a/gcc/ada/a-except-2005.ads b/gcc/ada/a-except-2005.ads index 0b248ff9879..5c00cf5b576 100644 --- a/gcc/ada/a-except-2005.ads +++ b/gcc/ada/a-except-2005.ads @@ -50,6 +50,8 @@ with System.Parameters; with System.Standard_Library; with System.Traceback_Entries; +with Ada.Unchecked_Conversion; + package Ada.Exceptions is pragma Warnings (Off); pragma Preelaborate_05; @@ -348,4 +350,18 @@ private Tracebacks => (others => TBE.Null_TB_Entry), Private_Data => System.Null_Address); + -- Common binding to __builtin_longjmp for sjlj variants. + + -- The builtin expects a pointer type for the jmpbuf address argument, and + -- System.Address doesn't work because this is really an integer type. + + type Jmpbuf_Address is access Character; + + function To_Jmpbuf_Address is new + Ada.Unchecked_Conversion (System.Address, Jmpbuf_Address); + + procedure builtin_longjmp (buffer : Jmpbuf_Address; Flag : Integer); + pragma No_Return (builtin_longjmp); + pragma Import (Intrinsic, builtin_longjmp, "__builtin_longjmp"); + end Ada.Exceptions; diff --git a/gcc/ada/a-exexpr.adb b/gcc/ada/a-exexpr.adb index 13b7d798328..e3ae5b01cff 100644 --- a/gcc/ada/a-exexpr.adb +++ b/gcc/ada/a-exexpr.adb @@ -41,10 +41,6 @@ pragma Warnings (Off); separate (Ada.Exceptions) package body Exception_Propagation is - procedure builtin_longjmp (buffer : Address; Flag : Integer); - pragma No_Return (builtin_longjmp); - pragma Import (C, builtin_longjmp, "_gnat_builtin_longjmp"); - --------------------- -- Setup_Exception -- --------------------- @@ -114,7 +110,7 @@ package body Exception_Propagation is Exception_Traces.Notify_Handled_Exception; end if; - builtin_longjmp (Jumpbuf_Ptr, 1); + builtin_longjmp (To_Jmpbuf_Address (Jumpbuf_Ptr), 1); else Exception_Traces.Notify_Unhandled_Exception; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 010e6bf9e10..761a113ab85 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -643,6 +643,20 @@ package body Exp_Disp is Typ := Non_Limited_View (Typ); end if; + -- Generate the SCIL node for this dispatching call. The SCIL node for a + -- dispatching call is inserted in the tree before the call is rewriten + -- and expanded because the SCIL node must be found by the SCIL backend + -- BEFORE the expanded nodes associated with the call node are found. + + if Generate_SCIL then + Insert_Action (Call_Node, + New_SCIL_Node + (SN_Kind => Dispatching_Call, + Related_Node => Call_Node, + Entity => Typ, + Target_Prim => Subp)); + end if; + if not Is_Limited_Type (Typ) then Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); end if; @@ -866,17 +880,6 @@ package body Exp_Disp is -- to avoid the generation of spurious warnings under ZFP run-time. Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks); - - -- Generate the SCIL node for this dispatching call - - if Generate_SCIL then - Insert_Action (Call_Node, - New_SCIL_Node - (SN_Kind => Dispatching_Call, - Related_Node => Call_Node, - Entity => Typ, - Target_Prim => Subp)); - end if; end Expand_Dispatching_Call; --------------------------------- diff --git a/gcc/ada/raise.c b/gcc/ada/raise.c index d82132354f8..1f087783b67 100644 --- a/gcc/ada/raise.c +++ b/gcc/ada/raise.c @@ -29,11 +29,8 @@ * * ****************************************************************************/ -/* Shared routines to support exception handling. - Note that _gnat_builtin_longjmp should disappear at some point, replaced - by direct call to __builtin_longjmp from Ada code. - __gnat_unhandled_terminate is code shared between all exception handling - mechanisms */ +/* Shared routines to support exception handling. __gnat_unhandled_terminate + is shared between all exception handling mechanisms. */ #ifdef IN_RTS #include "tconfig.h" @@ -46,13 +43,19 @@ #include "adaint.h" #include "raise.h" -/* We have not yet figured out how to import this directly */ +/* Wrapper to builtin_longjmp. This is for the compiler eh only, as the sjlj + runtime library interfaces directly to the intrinsic. We can't yet do + this for the compiler itself, because this capability relies on changes + made in april 2008 and we need to preserve the possibility to bootstrap + with an older base version. */ +#if defined (IN_GCC) && !defined (IN_RTS) void _gnat_builtin_longjmp (void *ptr, int flag ATTRIBUTE_UNUSED) { __builtin_longjmp (ptr, 1); } +#endif /* When an exception is raised for which no handler exists, the procedure Ada.Exceptions.Unhandled_Exception is called, which performs the call to diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 1786b51cee4..caf4cc7a0ee 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7142,19 +7142,33 @@ package body Sem_Util is Last_Assignment_Only : Boolean := False) is begin + -- ??? do we have to worry about clearing cached checks? + if Is_Assignable (Ent) then Set_Last_Assignment (Ent, Empty); end if; - if not Last_Assignment_Only and then Is_Object (Ent) then - Kill_Checks (Ent); - Set_Current_Value (Ent, Empty); + if Is_Object (Ent) then + if not Last_Assignment_Only then + Kill_Checks (Ent); + Set_Current_Value (Ent, Empty); - if not Can_Never_Be_Null (Ent) then - Set_Is_Known_Non_Null (Ent, False); + if not Can_Never_Be_Null (Ent) then + Set_Is_Known_Non_Null (Ent, False); + end if; + + Set_Is_Known_Null (Ent, False); + + -- Reset Is_Known_Valid unless type is always valid, or if we have + -- a loop parameter (loop parameters are always valid, since their + -- bounds are defined by the bounds given in the loop header). + + if not Is_Known_Valid (Etype (Ent)) + and then Ekind (Ent) /= E_Loop_Parameter + then + Set_Is_Known_Valid (Ent, False); + end if; end if; - - Set_Is_Known_Null (Ent, False); end if; end Kill_Current_Values; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 81dcf1f216c..0e3dde668e6 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -820,9 +820,9 @@ package Sem_Util is -- clear the Is_True_Constant flag, since that only gets reset if there -- really is an assignment somewhere in the entity scope). This procedure -- also calls Kill_All_Checks, since this is a special case of needing to - -- forget saved values. This procedure also clears Is_Known_Non_Null flags - -- in variables, constants or parameters since these are also not known to - -- be valid. + -- forget saved values. This procedure also clears the Is_Known_Null and + -- Is_Known_Non_Null and Is_Known_Valid flags in variables, constants or + -- parameters since these are also not known to be trustable any more. -- -- The Last_Assignment_Only flag is set True to clear only Last_Assignment -- fields and leave other fields unchanged. This is used when we encounter @@ -839,8 +839,8 @@ package Sem_Util is Last_Assignment_Only : Boolean := False); -- This performs the same processing as described above for the form with -- no argument, but for the specific entity given. The call has no effect - -- if the entity Ent is not for an object. Again, Last_Assignment_Only is - -- set if you want to clear only the Last_Assignment field (see above). + -- if the entity Ent is not for an object. Last_Assignment_Only has the + -- same meaning as for the call with no Ent. procedure Kill_Size_Check_Code (E : Entity_Id); -- Called when an address clause or pragma Import is applied to an entity.