Skip to content

Commit

Permalink
Merge branch 'eyraud/167' into 'master'
Browse files Browse the repository at this point in the history
manual dump: fix performance issue

Closes #167

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

Fixes eng/das/cov/gnatcoverage#167
  • Loading branch information
Jugst3r committed Dec 12, 2023
2 parents 41dab7c + 547b368 commit 29f3005
Showing 6 changed files with 104 additions and 64 deletions.
17 changes: 9 additions & 8 deletions tools/gnatcov/instrument-ada_unit.adb
Original file line number Diff line number Diff line change
@@ -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);
8 changes: 4 additions & 4 deletions tools/gnatcov/instrument-ada_unit.ads
Original file line number Diff line number Diff line change
@@ -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
118 changes: 77 additions & 41 deletions tools/gnatcov/instrument-c.adb
Original file line number Diff line number Diff line change
@@ -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;

8 changes: 4 additions & 4 deletions tools/gnatcov/instrument-c.ads
Original file line number Diff line number Diff line change
@@ -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:
11 changes: 7 additions & 4 deletions tools/gnatcov/instrument-common.ads
Original file line number Diff line number Diff line change
@@ -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;
6 changes: 3 additions & 3 deletions tools/gnatcov/instrument-projects.adb
Original file line number Diff line number Diff line change
@@ -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

0 comments on commit 29f3005

Please sign in to comment.