Merge branch 'eyraud/167' into 'master'

Jugst3r · Jugst3r · commit 29f30050f6b0 · 2023-12-12T17:13:12.000Z
manual dump: fix performance issue

Closes #167

See merge request eng/das/cov/gnatcoverage!350

Fixes eng/das/cov/gnatcoverage#167
diff --git a/tools/gnatcov/instrument-ada_unit.adb b/tools/gnatcov/instrument-ada_unit.adb
@@ -7799,10 +7799,10 @@ package body Instrument.Ada_Unit is
    ------------------------------------
 
    overriding procedure Replace_Manual_Dump_Indication
-     (Self   : in out Ada_Instrumenter_Type;
-      Done   : in out Boolean;
-      Prj    : in out Prj_Desc;
-      Source : GNATCOLL.Projects.File_Info)
+     (Self                  : in out Ada_Instrumenter_Type;
+      Prj                   : in out Prj_Desc;
+      Source                : GNATCOLL.Projects.File_Info;
+      Has_Manual_Indication : out Boolean)
    is
       Instrumented_Filename : constant String :=
         +(Prj.Output_Dir & "/" & GNATCOLL.VFS."+" (Source.File.Base_Name));
@@ -7853,7 +7853,7 @@ package body Instrument.Ada_Unit is
                   --  The pragma statement to be replaced by the actual call
                   --  to Dump_Buffers has been found.
 
-                  if not Done then
+                  if not Has_Manual_Indication then
                      Start_Rewriting (Rewriter, Self, Prj, File_To_Search);
                   end if;
 
@@ -7870,7 +7870,7 @@ package body Instrument.Ada_Unit is
                   begin
                      --  Add the with clause only once in the file
 
-                     if not Done then
+                     if not Has_Manual_Indication then
                         Insert_Last
                           (Handle (Unit.Root.As_Compilation_Unit.F_Prelude),
                            Create_From_Template
@@ -7891,7 +7891,7 @@ package body Instrument.Ada_Unit is
                            Rule => Call_Stmt_Rule));
                   end;
 
-                  Done := True;
+                  Has_Manual_Indication := True;
                   return Over;
                end if;
             end;
@@ -7913,11 +7913,12 @@ package body Instrument.Ada_Unit is
       --  initialized which will lead to finalization issues. To avoid this,
       --  make sure it is set to No_Rewriting_Handle.
 
+      Has_Manual_Indication := False;
       Rewriter.Handle := No_Rewriting_Handle;
 
       Unit.Root.Traverse (Find_And_Replace_Pragma'Access);
 
-      if Done then
+      if Has_Manual_Indication then
          Create_Directory_If_Not_Exists
            (GNATCOLL.VFS."+" (Source.Project.Object_Dir.Base_Dir_Name));
          Create_Directory_If_Not_Exists (+Prj.Output_Dir);
diff --git a/tools/gnatcov/instrument-ada_unit.ads b/tools/gnatcov/instrument-ada_unit.ads
@@ -86,10 +86,10 @@ package Instrument.Ada_Unit is
       Prj           : Prj_Desc);
 
    overriding procedure Replace_Manual_Dump_Indication
-     (Self   : in out Ada_Instrumenter_Type;
-      Done   : in out Boolean;
-      Prj    : in out Prj_Desc;
-      Source : GNATCOLL.Projects.File_Info);
+     (Self                  : in out Ada_Instrumenter_Type;
+      Prj                   : in out Prj_Desc;
+      Source                : GNATCOLL.Projects.File_Info;
+      Has_Manual_Indication : out Boolean);
    --  Once the instrumentation has finished, if the dump trigger is "manual"
    --  we expect the user to have indicated the place where a call to the
    --  manual dump buffers procedure should be inserted by the pragma
diff --git a/tools/gnatcov/instrument-c.adb b/tools/gnatcov/instrument-c.adb
@@ -17,7 +17,6 @@
 ------------------------------------------------------------------------------
 
 with Ada.Characters.Handling;
-with Ada.Characters.Latin_1;
 with Ada.Containers;  use Ada.Containers;
 with Ada.Directories; use Ada.Directories;
 with Ada.Text_IO;     use Ada.Text_IO;
@@ -30,6 +29,7 @@ with GNAT.OS_Lib; use GNAT.OS_Lib;
 with GNAT.Regpat; use GNAT.Regpat;
 
 with GNATCOLL.VFS;
+with GNATCOLL.Mmap;
 
 with Interfaces;           use Interfaces;
 with Interfaces.C;         use Interfaces.C;
@@ -3838,10 +3838,10 @@ package body Instrument.C is
    ------------------------------------
 
    overriding procedure Replace_Manual_Dump_Indication
-     (Self   : in out C_Family_Instrumenter_Type;
-      Done   : in out Boolean;
-      Prj    : in out Prj_Desc;
-      Source : GNATCOLL.Projects.File_Info)
+     (Self                  : in out C_Family_Instrumenter_Type;
+      Prj                   : in out Prj_Desc;
+      Source                : GNATCOLL.Projects.File_Info;
+      Has_Manual_Indication : out Boolean)
    is
       use GNATCOLL.VFS;
       Orig_Filename : constant String := +Source.File.Full_Name;
@@ -3851,16 +3851,15 @@ package body Instrument.C is
       declare
          Options        : Analysis_Options;
          PP_Filename    : Unbounded_String;
-         File           : Ada.Text_IO.File_Type;
          Dummy_Main     : Compilation_Unit_Part;
          Dump_Pat       : constant Pattern_Matcher :=
-           Compile ("^[\t ]*\/\* GNATCOV_DUMP_BUFFERS \*\/[ \t]*");
+           Compile
+             ("^[\t ]*\/\* GNATCOV_DUMP_BUFFERS \*\/[ \t]*",
+              Flags => Multiple_Lines);
          Matches        : Match_Array (0 .. 1);
          Dump_Procedure : constant String :=
            Dump_Procedure_Symbol
              (Main => Dummy_Main, Manual => True, Prj_Name => +Prj.Prj_Name);
-         Contents       : Unbounded_String :=
-           +("extern void " & Dump_Procedure & " (void);");
       begin
          --  Preprocess the source, keeping the comment to look for the manual
          --  dump indication later.
@@ -3887,47 +3886,84 @@ package body Instrument.C is
             end loop;
          end;
 
-         --  Look for the manual dump indication in the preprocessed file
+         --  Look for the manual dump indication in the preprocessed file. Use
+         --  the GNATCOLL.Mmap API to map the file contents in memory, as we
+         --  may need to rewrite it to the source file, with the manual dump
+         --  indication replaced by an actual call to the dump buffers
+         --  function.
 
-         Ada.Text_IO.Open
-           (File => File,
-            Mode => In_File,
-            Name => (+PP_Filename));
-
-         while not Ada.Text_IO.End_Of_File (File) loop
-            declare
-               Line : constant String := Get_Line (File);
-            begin
-               Match (Dump_Pat, Line, Matches);
+         declare
+            use GNATCOLL.Mmap;
+            File         : Mapped_File := Open_Read (To_String (PP_Filename));
+            Region       : Mapped_Region := Read (File);
+            Raw_Str      : constant Str_Access := Data (Region);
+            Raw_Str_Last : constant Natural := Last (Region);
+            Str          : String renames Raw_Str (1 .. Raw_Str_Last);
+
+            Tmp_Filename : constant String := +PP_Filename & ".tmp";
+            Output_File  : Ada.Text_IO.File_Type;
+            --  Temporary file containing the new version of the original file,
+            --  with inserted calls to dump buffers. The original file is then
+            --  overwritten by this temporary file.
+
+            Index : Positive := 1;
+            --  Starting index, or last index of the previous match in the
+            --  original file.
 
-               if Matches (0) /= No_Match then
-                  Contents := Contents & Dump_Procedure & "();";
-                  Done := True;
-               else
-                  Contents := Contents & Line;
+         begin
+            Has_Manual_Indication := False;
+            while Index in Str'Range loop
+               Match (Dump_Pat, Str (Index .. Str'Last), Matches);
+               exit when Matches (0) = No_Match;
+
+               --  Open the output file if this is the first match we find,
+               --  then forward the source code that appear before the match
+               --  unchanged.
+
+               if not Has_Manual_Indication then
+                  Create (Output_File, Out_File, Tmp_Filename);
+                  Has_Manual_Indication := True;
                end if;
+               Put (Output_File, Str (Index .. Matches (0).First));
 
-               Contents := Contents & Ada.Characters.Latin_1.LF;
-            end;
-         end loop;
+               --  Replace the match with the call to the dump procedure
+
+               Put (Output_File, Dump_Procedure & "();");
+               Index := Matches (0).Last + 1;
+            end loop;
 
-         Ada.Text_IO.Close (File);
+            --  If we had a manual indication, and thus wrote a modified source
+            --  file, overwrite the original source file with it.
 
-         if Done then
-            --  Content now holds the text of the original file with calls to
-            --  the manual dump procedure where the indications and its extern
-            --  declaration were. Replace the original content of the file with
-            --  Content.
+            if Has_Manual_Indication then
+               declare
+                  Tmp_File : constant Virtual_File := Create (+Tmp_Filename);
+                  Success  : Boolean;
+               begin
+                  --  Flush the rest of the file contents
 
-            Ada.Text_IO.Open
-              (File => File,
-               Mode => Out_File,
-               Name => (+PP_Filename));
+                  Ada.Text_IO.Put (Output_File, Str (Index .. Str'Last));
+                  Ada.Text_IO.Close (Output_File);
 
-            Ada.Text_IO.Put_Line (File, (+Contents));
+                  Free (Region);
+                  Close (File);
 
-            Ada.Text_IO.Close (File);
-         end if;
+                  --  Overwrite the original file with its newer version
+
+                  Tmp_File.Rename
+                    (Full_Name => Create (+(+PP_Filename)),
+                     Success   => Success);
+                  if not Success then
+                     Outputs.Fatal_Error
+                       ("Failed to replace manual dump indication for Source "
+                        & (+Source.File.Full_Name));
+                  end if;
+               end;
+            else
+               Free (Region);
+               Close (File);
+            end if;
+         end;
       end;
    end Replace_Manual_Dump_Indication;
 
diff --git a/tools/gnatcov/instrument-c.ads b/tools/gnatcov/instrument-c.ads
@@ -54,10 +54,10 @@ package Instrument.C is
       Prj         : Prj_Desc);
 
    overriding procedure Replace_Manual_Dump_Indication
-     (Self   : in out C_Family_Instrumenter_Type;
-      Done   : in out Boolean;
-      Prj    : in out Prj_Desc;
-      Source : GNATCOLL.Projects.File_Info);
+     (Self                  : in out C_Family_Instrumenter_Type;
+      Prj                   : in out Prj_Desc;
+      Source                : GNATCOLL.Projects.File_Info;
+      Has_Manual_Indication : out Boolean);
    --  Preprocess Source and look through the text content of the preprocessed
    --  file looking for manual dump indications. The C-like languages, the
    --  expected indication is the comment alone on its line:
diff --git a/tools/gnatcov/instrument-common.ads b/tools/gnatcov/instrument-common.ads
@@ -486,14 +486,17 @@ package Instrument.Common is
    --  the instrumented source files.
 
    procedure Replace_Manual_Dump_Indication
-     (Self   : in out Language_Instrumenter;
-      Done   : in out Boolean;
-      Prj    : in out Prj_Desc;
-      Source : GNATCOLL.Projects.File_Info) is null;
+     (Self                  : in out Language_Instrumenter;
+      Prj                   : in out Prj_Desc;
+      Source                : GNATCOLL.Projects.File_Info;
+      Has_Manual_Indication : out Boolean) is null;
    --  Look for the pragma (for Ada) or comment (for C family languages)
    --  indicating where the user wishes to the buffers to be dumped in Source.
    --  When found, replace it with a call to the buffers dump procedure defined
    --  in the dump helper unit.
+   --
+   --  Has_Manual_Indication indicates whether a manual dump indication was
+   --  found - and replaced with a call to dump buffers - in the given source.
 
    function New_File
      (Prj : Prj_Desc; Name : String) return String;
diff --git a/tools/gnatcov/instrument-projects.adb b/tools/gnatcov/instrument-projects.adb
@@ -865,9 +865,9 @@ is
                Contained_Indication : Boolean := False;
             begin
                Instrumenter.Replace_Manual_Dump_Indication
-                 (Contained_Indication,
-                  Prj_Info.Desc,
-                  Source);
+                 (Prj_Info.Desc,
+                  Source,
+                  Contained_Indication);
 
                if Contained_Indication and then not Is_Root_Prj then
 
