| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- G E N E R A T E _ M I N I M A L _ R E P R O D U C E R -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2024-2025, 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 AdaCore. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Atree; |
| with Fmap; |
| with Fname.UF; |
| with Lib; |
| with Namet; use Namet; |
| with Osint; use Osint; |
| with Output; use Output; |
| with Sinfo.Nodes; use Sinfo.Nodes; |
| with System.CRTL; |
| with System.OS_Lib; use System.OS_Lib; |
| with Types; use Types; |
| with Uname; |
| |
| procedure Generate_Minimal_Reproducer is |
| Reproducer_Generation_Failed : exception; |
| |
| function Create_Reproducer_Directory return String; |
| -- Create a directory that will be used to run adareducer, and will |
| -- eventually contain the reduced set of sources to be collected by the |
| -- user. The name of the directory makes its purpose clear, and it has a |
| -- numeric suffix to avoid clashes with other compiler invocations that |
| -- might have generated reproducers already. |
| |
| --------------------------------- |
| -- Create_Reproducer_Directory -- |
| --------------------------------- |
| |
| function Create_Reproducer_Directory return String is |
| Max_Id : constant Positive := 1000; |
| |
| Prefix : constant String := "reduce-crash-reproducer"; |
| |
| Result : System.CRTL.int; |
| begin |
| for Id in 1 .. Max_Id loop |
| declare |
| Candidate_Path : String := Prefix & Positive'Image (Id); |
| begin |
| Candidate_Path (Prefix'Length + 1) := '-'; |
| |
| Result := System.CRTL.mkdir (Candidate_Path & ASCII.NUL); |
| |
| -- If mkdir fails, we assume that it's because the directory |
| -- already exists. We should check for EEXIST instead??? |
| if Result = 0 then |
| return Candidate_Path; |
| end if; |
| end; |
| end loop; |
| |
| Write_Line ("failed to create reproducer directory"); |
| raise Reproducer_Generation_Failed; |
| end Create_Reproducer_Directory; |
| |
| Dirname : constant String := Create_Reproducer_Directory; |
| |
| Gpr_File_Path : constant String := |
| Dirname & Directory_Separator & "reduce_crash_reproducer.gpr"; |
| |
| Src_Dir_Path : constant String := Dirname & Directory_Separator & "src"; |
| |
| Oracle_Path : constant String := |
| Dirname & Directory_Separator & Executable_Name ("oracle"); |
| |
| Main_Library_Item : constant Node_Id := Unit (Lib.Cunit (Main_Unit)); |
| |
| -- There is a special case that we need to detect: when the main library |
| -- item is the instantiation of a generic that has a body, and the |
| -- instantiation of generic bodies has started. We start by binding whether |
| -- the main library item is an instantiation to the following constant. |
| Main_Is_Instantiation : constant Boolean := |
| Nkind (Atree.Original_Node (Main_Library_Item)) |
| in N_Generic_Instantiation; |
| |
| -- If the main library item is an instantiation and its unit name is a body |
| -- name, it means that Make_Instance_Unit has been called. We need to use |
| -- the corresponding spec name to reconstruct the on-disk form of the |
| -- semantic closure. |
| Main_Unit_Name : constant Unit_Name_Type := |
| (if Main_Is_Instantiation |
| and then Uname.Is_Body_Name (Lib.Unit_Name (Main_Unit)) |
| then Uname.Get_Spec_Name (Lib.Unit_Name (Main_Unit)) |
| else Lib.Unit_Name (Main_Unit)); |
| |
| Result : Integer; |
| begin |
| Create_Semantic_Closure_Project : |
| declare |
| Gpr_File : File_Descriptor; |
| |
| B : constant Saved_Output_Buffer := Save_Output_Buffer; |
| begin |
| Gpr_File := Create_File (Gpr_File_Path, Text); |
| if Gpr_File = Invalid_FD then |
| Write_Line ("failed to create GPR file"); |
| raise Reproducer_Generation_Failed; |
| end if; |
| |
| Push_Output; |
| Set_Output (Gpr_File); |
| |
| Write_Line ("project Reduce_Crash_Reproducer is"); |
| Write_Line (" for Source_Dirs use (""src"");"); |
| Write_Line ("end Reduce_Crash_Reproducer;"); |
| |
| Close (Gpr_File); |
| Pop_Output; |
| Restore_Output_Buffer (B); |
| |
| Result := System.CRTL.mkdir (Src_Dir_Path & ASCII.NUL); |
| |
| if Result /= 0 then |
| Write_Line ("failed to create reproducer directory"); |
| raise Reproducer_Generation_Failed; |
| end if; |
| |
| for J in Main_Unit .. Lib.Last_Unit loop |
| -- We skip library units that fall under one of the following cases: |
| -- - Internal library units. |
| -- - Units that were synthesized for child subprograms without spec |
| -- files. |
| -- - Dummy entries that Add_Preprocessing_Dependency puts in |
| -- Lib.Units. |
| -- Those cases correspond to the conjuncts in the condition below. |
| if not Lib.Is_Internal_Unit (J) |
| and then Comes_From_Source (Lib.Cunit (J)) |
| and then Lib.Unit_Name (J) /= No_Unit_Name |
| then |
| declare |
| Path : File_Name_Type := |
| Fmap.Mapped_Path_Name (Lib.Unit_File_Name (J)); |
| |
| Unit_Name : constant Unit_Name_Type := |
| (if J = Main_Unit then Main_Unit_Name else Lib.Unit_Name (J)); |
| |
| Default_File_Name : constant String := |
| Fname.UF.Get_Default_File_Name (Unit_Name); |
| |
| File_Copy_Path : constant String := |
| Src_Dir_Path & Directory_Separator & Default_File_Name; |
| begin |
| -- Mapped_Path_Name might have returned No_File. This has been |
| -- observed for files with a Source_File_Name pragma. |
| if Path = No_File then |
| Path := Find_File (Lib.Unit_File_Name (J), Osint.Source); |
| pragma Assert (Path /= No_File); |
| end if; |
| |
| declare |
| File_Path : constant String := Get_Name_String (Path); |
| Success : Boolean; |
| begin |
| System.OS_Lib.Copy_File |
| (File_Path, File_Copy_Path, Success, Overwrite); |
| |
| pragma Assert (Success); |
| end; |
| end; |
| end if; |
| end loop; |
| end Create_Semantic_Closure_Project; |
| |
| Create_Oracle : |
| declare |
| Gnatmake_Path : String_Access := Locate_Exec_On_Path ("gnatmake"); |
| |
| Oracle_Dir_Path : constant String := |
| Dirname & Directory_Separator & "oracle-src"; |
| |
| Source_File_Path : constant String := |
| Oracle_Dir_Path & Directory_Separator & "oracle.adb"; |
| |
| Source_File : File_Descriptor; |
| |
| Result : System.CRTL.int; |
| begin |
| if Gnatmake_Path = null then |
| Write_Line ("-gnatd_m was specified but gnatmake is not available"); |
| raise Reproducer_Generation_Failed; |
| end if; |
| |
| Result := System.CRTL.mkdir (Oracle_Dir_Path & ASCII.NUL); |
| |
| if Result /= 0 then |
| Write_Line ("failed to create directory"); |
| raise Reproducer_Generation_Failed; |
| end if; |
| |
| Source_File := Create_File (Source_File_Path, Text); |
| if Source_File = Invalid_FD then |
| Write_Line ("failed to create oracle source file"); |
| raise Reproducer_Generation_Failed; |
| end if; |
| |
| Write_Oracle_Code : |
| declare |
| Old_Main_Path : constant String := |
| Get_Name_String |
| (Fmap.Mapped_Path_Name (Lib.Unit_File_Name (Main_Unit))); |
| |
| Default_Main_Name : constant String := |
| Fname.UF.Get_Default_File_Name (Main_Unit_Name); |
| |
| New_Main_Path : constant String := |
| Src_Dir_Path & Directory_Separator & Default_Main_Name; |
| |
| Gnat1_Path : String (1 .. Len_Arg (0)); |
| |
| B : constant Saved_Output_Buffer := Save_Output_Buffer; |
| begin |
| Fill_Arg (Gnat1_Path'Address, 0); |
| |
| Push_Output; |
| Set_Output (Source_File); |
| |
| Write_Line ("with Ada.Command_Line;"); |
| Write_Line ("use Ada.Command_Line;"); |
| Write_Line ("with GNAT.Expect;"); |
| Write_Line ("with GNAT.OS_Lib;"); |
| Write_Eol; |
| Write_Line ("procedure Oracle is"); |
| Write_Line (" Child_Code : aliased Integer;"); |
| Write_Eol; |
| Write_Line (" Gnat1_Path : constant String := "); |
| |
| Write_Str (" """); |
| Write_Str (Gnat1_Path); |
| Write_Line (""";"); |
| |
| Write_Eol; |
| Write_Line (" Args : constant GNAT.OS_Lib.Argument_List :="); |
| |
| Write_Str |
| (" (new String'(""-quiet""), new String'(""-gnatd_M"")"); |
| |
| -- The following way of iterating through the command line arguments |
| -- was copied from Set_Targ. TODO factorize??? |
| declare |
| type Arg_Array is array (Nat) of Big_String_Ptr; |
| type Arg_Array_Ptr is access Arg_Array; |
| -- Types to access compiler arguments |
| |
| save_argc : Nat; |
| pragma Import (C, save_argc); |
| -- Saved value of argc (number of arguments), imported from |
| -- misc.cc |
| |
| save_argv : Arg_Array_Ptr; |
| pragma Import (C, save_argv); |
| -- Saved value of argv (argument pointers), imported from misc.cc |
| |
| gnat_argc : Nat; |
| gnat_argv : Arg_Array_Ptr; |
| pragma Import (C, gnat_argc); |
| pragma Import (C, gnat_argv); |
| -- If save_argv is not set, default to gnat_argc/argv |
| |
| argc : Nat; |
| argv : Arg_Array_Ptr; |
| |
| function Len_Arg (Arg : Big_String_Ptr) return Nat; |
| -- Determine length of argument Arg (a nul terminated C string). |
| |
| ------------- |
| -- Len_Arg -- |
| ------------- |
| |
| function Len_Arg (Arg : Big_String_Ptr) return Nat is |
| begin |
| for J in 1 .. Nat'Last loop |
| if Arg (Natural (J)) = ASCII.NUL then |
| return J - 1; |
| end if; |
| end loop; |
| |
| raise Program_Error; |
| end Len_Arg; |
| |
| begin |
| if save_argv /= null then |
| argv := save_argv; |
| argc := save_argc; |
| else |
| -- Case of a non-GCC compiler, e.g. gnat2why or gnat2scil |
| argv := gnat_argv; |
| argc := gnat_argc; |
| end if; |
| |
| for Arg in 1 .. argc - 1 loop |
| declare |
| Argv_Ptr : constant Big_String_Ptr := argv (Arg); |
| Argv_Len : constant Nat := Len_Arg (Argv_Ptr); |
| |
| Arg : constant String := Argv_Ptr (1 .. Natural (Argv_Len)); |
| begin |
| -- We filter out mapping file arguments because we want to |
| -- use the copies of source files we made. |
| if Argv_Len > 8 and then Arg (1 .. 8) = "-gnatem=" then |
| null; |
| |
| -- We must not have the oracle run the compiler in |
| -- reduce-on-crash mode, that would result in recursive |
| -- invocations. |
| elsif Arg = "-gnatd_m" then |
| null; |
| else |
| Write_Line (","); |
| Write_Str (" new String'("""); |
| |
| -- We replace references to the main source file with |
| -- references to the copy we made. |
| if Old_Main_Path = Arg then |
| Write_Str (New_Main_Path); |
| |
| -- We copy the other command line arguments unmodified |
| else |
| Write_Str (Arg); |
| end if; |
| |
| Write_Str (""")"); |
| end if; |
| end; |
| end loop; |
| end; |
| |
| Write_Line (");"); |
| |
| Write_Eol; |
| |
| Write_Line (" Output : constant String :="); |
| Write_Line (" GNAT.Expect.Get_Command_Output"); |
| Write_Str (" (Gnat1_Path, Args, """", Child_Code'Access, "); |
| Write_Line ("Err_To_Out => True);"); |
| |
| Write_Eol; |
| |
| Write_Line (" Crash_Marker : constant String :="); |
| Write_Line (" ""+===========================GNAT BUG DETECTE"";"); |
| |
| Write_Eol; |
| |
| Write_Line (" Crashed : constant Boolean :="); |
| Write_Line (" Crash_Marker'Length <= Output'Length"); |
| Write_Str (" and then Output (Output'First .. Output'First "); |
| Write_Line ("+ Crash_Marker'Length - 1)"); |
| Write_Line (" = Crash_Marker;"); |
| |
| Write_Eol; |
| |
| Write_Str (" Status_Code : Exit_Status := "); |
| Write_Line ("(if Crashed then 0 else 1);"); |
| Write_Line ("begin"); |
| Write_Line (" Set_Exit_Status (Status_Code);"); |
| Write_Line ("end Oracle;"); |
| |
| Pop_Output; |
| Restore_Output_Buffer (B); |
| end Write_Oracle_Code; |
| |
| Close (Source_File); |
| |
| declare |
| Args : constant Argument_List := |
| (new String'(Source_File_Path), |
| new String'("-o"), |
| new String'(Oracle_Path), |
| new String'("-D"), |
| new String'(Oracle_Dir_Path)); |
| |
| Success : Boolean; |
| begin |
| Spawn (Gnatmake_Path.all, Args, Success); |
| |
| pragma Assert (Success); |
| end; |
| |
| Free (Gnatmake_Path); |
| end Create_Oracle; |
| |
| Run_Adareducer : |
| declare |
| -- See section 12.8.3 of the GNAT Studio user's guide for documentation |
| -- about how to invoke adareducer. |
| Gnatstudio_Cli_Path : String_Access := |
| Locate_Exec_On_Path ("gnatstudio_cli"); |
| |
| begin |
| if Gnatstudio_Cli_Path = null then |
| Write_Line ("-gnatd_m was specified but adareducer is not available"); |
| return; |
| end if; |
| |
| declare |
| Args : constant Argument_List := |
| (new String'("adareducer"), |
| new String'("-P"), |
| new String'(Gpr_File_Path), |
| new String'("-s"), |
| new String'(Oracle_Path)); |
| |
| Success : Boolean; |
| begin |
| Spawn (Gnatstudio_Cli_Path.all, Args, Success); |
| pragma Assert (Success); |
| end; |
| |
| Free (Gnatstudio_Cli_Path); |
| end Run_Adareducer; |
| |
| Clean_Up_Reproducer_Source : |
| declare |
| |
| use type System.Address; |
| |
| Directory_Stream : System.CRTL.DIRs; |
| |
| function opendir (file_name : String) return System.CRTL.DIRs with |
| Import, Convention => C, External_Name => "__gnat_opendir"; |
| |
| Conservative_Name_Max : constant Positive := 4096; |
| |
| Buffer : String (1 .. Conservative_Name_Max); |
| Length : aliased Integer; |
| |
| Addr : System.Address; |
| |
| Dummy : Integer; |
| |
| Dummy_Success : Boolean; |
| |
| function readdir |
| (Directory : System.CRTL.DIRs; |
| Buffer : System.Address; |
| Length : access Integer) return System.Address |
| with Import, Convention => C, External_Name => "__gnat_readdir"; |
| |
| function closedir (directory : System.CRTL.DIRs) return Integer with |
| Import, Convention => C, External_Name => "__gnat_closedir"; |
| |
| begin |
| Directory_Stream := opendir (Src_Dir_Path & ASCII.NUL); |
| |
| if Directory_Stream = System.Null_Address then |
| return; |
| end if; |
| |
| loop |
| Addr := readdir (Directory_Stream, Buffer'Address, Length'Access); |
| if Addr = System.Null_Address then |
| exit; |
| end if; |
| |
| declare |
| S : constant String := Buffer (1 .. Length); |
| begin |
| if (5 <= S'Length and then S (S'Last - 4 .. S'Last) = ".orig") |
| or else (2 <= S'Length and then S (S'Last - 1 .. S'Last) = ".s") |
| then |
| System.OS_Lib.Delete_File |
| (Src_Dir_Path & Directory_Separator & S, Dummy_Success); |
| end if; |
| end; |
| end loop; |
| |
| Dummy := closedir (Directory_Stream); |
| end Clean_Up_Reproducer_Source; |
| end Generate_Minimal_Reproducer; |
