path: root/gcc/ada/generate_minimal_reproducer.adb

------------------------------------------------------------------------------
--                                                                          --
--                         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, 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 Fmap;
with Fname.UF;
with Lib;
with Namet; use Namet;
with Osint; use Osint;
with Output; use Output;
with Sinfo.Nodes;
with System.CRTL;
with System.OS_Lib; use System.OS_Lib;
with Types; use Types;

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");

   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
         declare
            Path : File_Name_Type :=
              Fmap.Mapped_Path_Name (Lib.Unit_File_Name (J));

            Default_File_Name : constant String :=
              Fname.UF.Get_Default_File_Name (Lib.Unit_Name (J));

            File_Copy_Path : constant String :=
              Src_Dir_Path & Directory_Separator & Default_File_Name;

            --  We may have synthesized units for child subprograms without
            --  spec files. We need to filter out those units because we would
            --  create bogus spec files that break compilation if we didn't.
            Is_Synthetic_Subprogram_Spec : constant Boolean :=
              not Sinfo.Nodes.Comes_From_Source (Lib.Cunit (J));
         begin
            if not Lib.Is_Internal_Unit (J)
              and then not Is_Synthetic_Subprogram_Spec
            then
               --  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 if;
         end;
      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 (Lib.Unit_Name (Main_Unit));

         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'(""-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;