From 8f71d067d407ba3a635f9c4e161ef27487f5c237 Mon Sep 17 00:00:00 2001 From: charlet Date: Thu, 15 Jul 2004 20:34:43 +0000 Subject: 2004-07-15 Robert Dewar * makegpr.adb, s-secsta.ads, sem_ch3.adb, sem_case.adb: Minor reformatting * gnat_ugn.texi: Add instantiation of direct_io or sequential_io with access values as an example of a warning. * gnat_rm.texi: Document new attribute Has_Access_Values * gnat-style.texi: Document that box comments belong on nested subprograms * sem_util.ads (Has_Access_Values): Improved documentation * s-finimp.ads, s-finimp.adb: Fix spelling error in comment * sem_prag.adb (Check_Duplicated_Export_Name): New procedure (Process_Interface_Name): Call to this new procedure (Set_Extended_Import_Export_External_Name): Call to this new procedure * s-mastop-x86.adb, 9drpc.adb: Fix spelling error in comment * a-direio.ads, a-sequio.ads: Warn if Element_Type has access values * einfo.ads: Minor comment typo fixed 2004-07-15 Jose Ruiz * snames.adb: Add _atcb. * snames.ads: Add Name_uATCB. * s-tarest.adb (Create_Restricted_Task): ATCBs are always preallocated (in the expanded code) when using the restricted run time. * s-tarest.ads (Create_Restricted_Task): Created_Task transformed into a in parameter in order to allow ATCBs to be preallocated (in the expanded code). * s-taskin.adb (Initialize_ATCB): T converted into a in parameter in order to allow ATCBs to be preallocated. In case of error, the ATCB is deallocated in System.Tasking.Stages. * s-taskin.ads (Initialize_ATCB): T converted into a in parameter in order to allow ATCBs to be preallocated. * s-tassta.adb (Create_Task): In case of error the ATCB is deallocated here. It was previously done in Initialize_ATCB. * rtsfind.ads: Make the Ada_Task_Control_Block visible. * exp_ch9.adb: Preallocate the Ada_Task_Control_Block when using the Restricted run time. * exp_ch3.adb: When using the Restricted run time, pass the preallocated Ada_Task_Control_Block when creating a task. 2004-07-15 Ed Schonberg * sem_util.adb (Normalize_Actuals): If there are no actuals on a function call that is itself an actual in an enclosing call, diagnose problem here rather than assuming that resolution will catch it. * sem_ch7.adb (Analyze_Package_Specification): If the specification is the local copy of a generic unit for a formal package, and the generic is a child unit, install private part of ancestors before compiling private part of spec. * sem_cat.adb (Validate_Categorization_Dependency): Simplify code to use scope entities rather than tree structures, to handle properly parent units that are instances rewritten as bodies for inlining purposes. * sem_ch10.adb (Get_Parent_Entity, Implicit_With_On_Parent, Remove_Parents): Handle properly a parent unit that is an instantiation, when the unit has been rewritten as a body for inlining purposes. * par.adb (Goto_List): Global variable to collect goto statements in a given unit, for use in detecting natural loops. * par-ch5.adb (P_Goto_Statement): Add goto to global Goto_List, for use in detecting natural loops. * par-labl.adb (Find_Natural_Loops): Recognize loops create by backwards goto's, and rewrite as a infinite loop, to improve locality of temporaries. * exp_util.adb (Force_Evaluation): Recognize a left-hand side subcomponent that includes an indexed reference, to prevent the generation of copies that would miscompile the desired assignment statement. (Build_Task_Image_Decls): Add a numeric suffix to generated name for string variable, to avoid spurious conflicts with the name of the type of a single protected object. * exp_ch4.adb (Expand_Array_Equality): If indices are distinct, use a loop with an explicit exit statement, to avoid generating an out-of-range value with 'Succ leading to spurious constraint_errors when compiling with -gnatVo. 2004-07-15 Thomas Quinot * sem_ch4.adb (Analyze_Slice): Always call Analyze on the prefix: it might not be analyzed yet, even if its Etype is already set (case of an unchecked conversion built using Unchecked_Convert_To, for example). If the prefix has already been analyzed, this will be a nop anyway. * exp_ch5.adb (Make_Tag_Ctrl_Assignment): For an assignment of a controller type, or an assignment of a record type with controlled components, copy only user data, and leave the finalization chain pointers untouched. 2004-07-15 Vincent Celier * make.adb (Collect_Arguments): Improve error message when attempting to compile a source not part of any project, when -x is not used. * prj.ads: (Defined_Variable_Kind): New subtype * prj-attr.adb (Register_New_Package): Two new procedures to register a package with or without its attributes. (Register_New_Attribute): Mew procedure to register a new attribute in a package. New attribute oriented subprograms: Attribute_Node_Id_Of, Attribute_Kind_Of, Set_Attribute_Kind_Of, Attribute_Name_Of, Variable_Kind_Of, Set_Variable_Kind_Of, Optional_Index_Of, Next_Attribute. New package oriented subprograms: Package_Node_Id_Of, Add_Unknown_Package, First_Attribute_Of, Add_Attribute. * prj-attr.ads (Attribute_Node_Id): Now a private, self initialized type. (Package_Node_Id): Now a private, self initialized type (Register_New_Package): New procedure to register a package with its attributes. New attribute oriented subprograms: Attribute_Node_Id_Of, Attribute_Kind_Of, Set_Attribute_Kind_Of, Attribute_Name_Of, Variable_Kind_Of, Set_Variable_Kind_Of, Optional_Index_Of, Next_Attribute. New package oriented subprograms: Package_Node_Id_Of, Add_Unknown_Package, First_Attribute_Of, Add_Attribute. * prj-dect.adb (Parse_Attribute_Declaration, Parse_Package_Declaration): Adapt to new spec of Prj.Attr. * prj-makr.adb (Make): Parse existing project file before creating other files. Fail if there was an error during parsing. * prj-proc.adb (Add_Attributes, Process_Declarative_Items): Adapt to new spec of Prj.Attr. * prj-strt.adb (Attribute_Reference, Parse_Variable_Reference): Adapt to new spec of Prj.Attr. 2004-07-15 Richard Kenner * utils2.c: Fix typo in comment. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@84774 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/par-labl.adb | 332 ++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 331 insertions(+), 1 deletion(-) (limited to 'gcc/ada/par-labl.adb') diff --git a/gcc/ada/par-labl.adb b/gcc/ada/par-labl.adb index 835be36e337..2fd70e5c09c 100644 --- a/gcc/ada/par-labl.adb +++ b/gcc/ada/par-labl.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004, 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- -- @@ -51,6 +51,11 @@ procedure Labl is -- Checks the rule in RM-5.1(11), which requires distinct identifiers -- for all the labels in a given body. + procedure Find_Natural_Loops; + -- Recognizes loops created by backward gotos, and rewrites the + -- corresponding statements into a proper loop, for optimization + -- purposes (for example, to control reclaiming local storage). + --------------------------- -- Check_Distinct_Labels -- --------------------------- @@ -145,6 +150,329 @@ procedure Labl is return Result; end Find_Enclosing_Body_Or_Block; + ------------------------ + -- Find_Natural_Loops -- + ------------------------ + + procedure Find_Natural_Loops is + Node_List : constant Elist_Id := New_Elmt_List; + N : Elmt_Id; + Succ : Elmt_Id; + + function Goto_Id (Goto_Node : Node_Id) return Name_Id; + -- Find Name_Id of goto statement, which may be an expanded name. + + function Matches + (Label_Node : Node_Id; + Goto_Node : Node_Id) return Boolean; + -- A label and a goto are candidates for a loop if the names match, + -- and both nodes appear in the same body. In addition, both must + -- appear in the same statement list. If they are not in the same + -- statement list, the goto is from within an nested structure, and + -- the label is not a header. We ignore the case where the goto is + -- within a conditional structure, and capture only infinite loops. + + procedure Merge; + -- Merge labels and goto statements in order of increasing sloc value. + -- Discard labels of loop and block statements. + + procedure No_Header (N : Elmt_Id); + -- The label N is known not to be a loop header. Scan forward and + -- remove all subsequent goto's that may have this node as a target. + + procedure Process_Goto (N : Elmt_Id); + -- N is a forward jump. Scan forward and remove all subsequent goto's + -- that may have the same target, to preclude spurious loops. + + procedure Rewrite_As_Loop + (Loop_Header : Node_Id; + Loop_End : Node_Id); + -- Given a label and a backwards goto, rewrite intervening statements + -- as a loop. Remove the label from the node list, and rewrite the + -- goto with the body of the new loop. + + procedure Try_Loop (N : Elmt_Id); + -- N is a label that may be a loop header. Scan forward to find some + -- backwards goto with which to make a loop. Do nothing if there is + -- an intervening label that is not part of a loop, or more than one + -- goto with this target. + + ------------- + -- Goto_Id -- + ------------- + + function Goto_Id (Goto_Node : Node_Id) return Name_Id is + begin + if Nkind (Name (Goto_Node)) = N_Identifier then + return Chars (Name (Goto_Node)); + + elsif Nkind (Name (Goto_Node)) = N_Selected_Component then + return Chars (Selector_Name (Name (Goto_Node))); + else + + -- In case of error, return Id that can't match anything + + return Name_Null; + end if; + end Goto_Id; + + ------------- + -- Matches -- + ------------- + + function Matches + (Label_Node : Node_Id; + Goto_Node : Node_Id) return Boolean + is + begin + return Chars (Identifier (Label_Node)) = Goto_Id (Goto_Node) + and then Find_Enclosing_Body (Label_Node) = + Find_Enclosing_Body (Goto_Node); + end Matches; + + ----------- + -- Merge -- + ----------- + + procedure Merge is + L1 : Elmt_Id; + G1 : Elmt_Id; + + begin + L1 := First_Elmt (Label_List); + G1 := First_Elmt (Goto_List); + + while Present (L1) + and then Present (G1) + loop + if Sloc (Node (L1)) < Sloc (Node (G1)) then + + -- Optimization: remove labels of loops and blocks, which + -- play no role in what follows. + + if Nkind (Node (L1)) /= N_Loop_Statement + and then Nkind (Node (L1)) /= N_Block_Statement + then + Append_Elmt (Node (L1), Node_List); + end if; + + Next_Elmt (L1); + + else + Append_Elmt (Node (G1), Node_List); + Next_Elmt (G1); + end if; + end loop; + + while Present (L1) loop + Append_Elmt (Node (L1), Node_List); + Next_Elmt (L1); + end loop; + + while Present (G1) loop + Append_Elmt (Node (G1), Node_List); + Next_Elmt (G1); + end loop; + end Merge; + + --------------- + -- No_Header -- + --------------- + + procedure No_Header (N : Elmt_Id) is + S1, S2 : Elmt_Id; + + begin + S1 := Next_Elmt (N); + while Present (S1) loop + S2 := Next_Elmt (S1); + if Nkind (Node (S1)) = N_Goto_Statement + and then Matches (Node (N), Node (S1)) + then + Remove_Elmt (Node_List, S1); + end if; + + S1 := S2; + end loop; + end No_Header; + + ------------------ + -- Process_Goto -- + ------------------ + + procedure Process_Goto (N : Elmt_Id) is + Goto1 : constant Node_Id := Node (N); + Goto2 : Node_Id; + S, S1 : Elmt_Id; + + begin + S := Next_Elmt (N); + + while Present (S) loop + S1 := Next_Elmt (S); + Goto2 := Node (S); + + if Nkind (Goto2) = N_Goto_Statement + and then Goto_Id (Goto1) = Goto_Id (Goto2) + and then Find_Enclosing_Body (Goto1) = + Find_Enclosing_Body (Goto2) + then + + -- Goto2 may have the same target, remove it from + -- consideration. + + Remove_Elmt (Node_List, S); + end if; + + S := S1; + end loop; + end Process_Goto; + + --------------------- + -- Rewrite_As_Loop -- + --------------------- + + procedure Rewrite_As_Loop + (Loop_Header : Node_Id; + Loop_End : Node_Id) + is + Loop_Body : constant List_Id := New_List; + Loop_Stmt : constant Node_Id := + New_Node (N_Loop_Statement, Sloc (Loop_Header)); + Stat : Node_Id; + Next_Stat : Node_Id; + begin + Stat := Next (Loop_Header); + while Stat /= Loop_End loop + Next_Stat := Next (Stat); + Remove (Stat); + Append (Stat, Loop_Body); + Stat := Next_Stat; + end loop; + + Set_Statements (Loop_Stmt, Loop_Body); + Set_Identifier (Loop_Stmt, Identifier (Loop_Header)); + + Remove (Loop_Header); + Rewrite (Loop_End, Loop_Stmt); + Error_Msg_N + ("code between label and backwards goto rewritten as loop?", + Loop_End); + end Rewrite_As_Loop; + + -------------- + -- Try_Loop -- + -------------- + + procedure Try_Loop (N : Elmt_Id) is + Source : Elmt_Id; + Found : Boolean := False; + S1 : Elmt_Id; + + begin + S1 := Next_Elmt (N); + while Present (S1) loop + if Nkind (Node (S1)) = N_Goto_Statement + and then Matches (Node (N), Node (S1)) + then + if not Found then + if Parent (Node (N)) = Parent (Node (S1)) then + Source := S1; + Found := True; + + else + -- The goto is within some nested structure + + No_Header (N); + return; + end if; + + else + -- More than one goto with the same target + + No_Header (N); + return; + end if; + + elsif Nkind (Node (S1)) = N_Label + and then not Found + then + -- Intervening label before possible end of loop. Current + -- label is not a candidate. This is conservative, because + -- the label might not be the target of any jumps, but not + -- worth dealing with useless labels! + + No_Header (N); + return; + + else + -- If the node is a loop_statement, it corresponds to a + -- label-goto pair rewritten as a loop. Continue forward scan. + + null; + end if; + + Next_Elmt (S1); + end loop; + + if Found then + Rewrite_As_Loop (Node (N), Node (Source)); + Remove_Elmt (Node_List, N); + Remove_Elmt (Node_List, Source); + end if; + end Try_Loop; + + begin + -- Start of processing for Find_Natural_Loops + + Merge; + + N := First_Elmt (Node_List); + while Present (N) loop + Succ := Next_Elmt (N); + + if Nkind (Node (N)) = N_Label then + if No (Succ) then + exit; + + elsif Nkind (Node (Succ)) = N_Label then + Try_Loop (Succ); + + -- If a loop was found, the label has been removed, and + -- the following goto rewritten as the loop body. + + Succ := Next_Elmt (N); + + if Nkind (Node (Succ)) = N_Label then + + -- Following label was not removed, so current label + -- is not a candidate header. + + No_Header (N); + + else + + -- Following label was part of inner loop. Current + -- label is still a candidate. + + Try_Loop (N); + Succ := Next_Elmt (N); + end if; + + elsif Nkind (Node (Succ)) = N_Goto_Statement then + Try_Loop (N); + Succ := Next_Elmt (N); + end if; + + elsif Nkind (Node (N)) = N_Goto_Statement then + Process_Goto (N); + Succ := Next_Elmt (N); + end if; + + N := Succ; + end loop; + end Find_Natural_Loops; + -- Start of processing for Par.Labl begin @@ -204,4 +532,6 @@ begin Next_Elmt (Next_Label_Elmt); end loop; + Find_Natural_Loops; + end Labl; -- cgit v1.2.1