Add time and counter profiling to CSV file

Initial work by Emilien Lemaire <emilien.lemaire@ocamlpro.com>

cobc/ChangeLog

@@ -1,3 +1,9 @@
+2023-09-04  Fabrice Le Fessant <fabrice.le_fessant@ocamlpro.com> and Emilien Lemaire <emilien.lemaire@ocamlpro.com>
+
+	* parser.y: generate `cob_prof_section/paragraph_enter/exit` calls when
+	  needed
+	* flag.def: add `-fprof` to enable profiling
+	* codegen.c: handle profiling code generation
 
 2023-07-26  Simon Sobisch <simonsobisch@gnu.org>
 

cobc/cobc.c

@@ -1446,7 +1446,7 @@ cobc_check_string (const char *dupstr)
 	return s->val;
 }
 
-static struct cb_text_list *
+struct cb_text_list *
 cb_text_list_add (struct cb_text_list *list, const char *text)
 {
 	struct cb_text_list	*p;

cobc/cobc.h

@@ -684,4 +684,8 @@ extern int		cb_strcasecmp (const void *, const void *);
 extern unsigned char	cb_toupper (const unsigned char);
 extern unsigned char	cb_tolower (const unsigned char);
 
+
+extern struct cb_text_list *
+cb_text_list_add (struct cb_text_list *list, const char *text);
+
 #endif /* CB_COBC_H */

cobc/codegen.c

@@ -4295,6 +4295,91 @@ output_funcall_item (cb_tree x, const int i, unsigned int func_nolitcast)
 }
 
 
+
+/* Data and functions used for profiling */
+static struct cb_text_list *procedures_list;
+static int procedures_list_len = 0;
+
+static const char *cob_prof_exit_paragraph_str = "cob_prof_exit_paragraph";
+static const char *cob_prof_exit_section_str = "cob_prof_exit_section";
+static const char *cob_prof_enter_paragraph_str = "cob_prof_enter_paragraph";
+static const char *cob_prof_enter_section_str = "cob_prof_enter_section";
+
+
+/* Returns the name of the procedure as expected by profiling
+ * formats. The string is statically allocated, so it must be
+ * reallocated for long term usage. */
+static char*
+get_procedure_name (struct cb_label *section, struct cb_label *paragraph)
+{
+	static char procedure_name[COB_NORMAL_BUFF];
+
+	if (paragraph){
+		sprintf (procedure_name, "%s|%s|%s:%d", section->name, paragraph->name,
+			 paragraph->common.source_file, paragraph->common.source_line);
+	} else {
+		sprintf (procedure_name, "%s||%s:%d", section->name,
+			 section->common.source_file, section->common.source_line);
+	}
+	return procedure_name;
+}
+
+/* Returns a tree node for a funcall to one of the profiling functions, with the name of the procedure
+   as argument. If the procedure is being entered, register the procedure into procedures_list. */
+cb_tree
+cb_build_prof_call (enum cb_prof_call prof_call, struct cb_label *section, struct cb_label *paragraph)
+{
+	const char* prof_call_name;
+	const char* name;
+	cb_tree	    cb_str;
+	int declare_procedure = 0;
+
+	switch (prof_call){
+	case COB_PROF_EXIT_PARAGRAPH:
+		prof_call_name = cob_prof_exit_paragraph_str;
+		break;
+	case COB_PROF_EXIT_SECTION:
+		prof_call_name = cob_prof_exit_section_str;
+		paragraph = NULL;
+		break;
+	case COB_PROF_ENTER_PARAGRAPH:
+		prof_call_name = cob_prof_enter_paragraph_str;
+		declare_procedure = 1;
+		break;
+	case COB_PROF_ENTER_SECTION:
+		prof_call_name = cob_prof_enter_section_str;
+		paragraph = NULL;
+		declare_procedure = 1;
+		break;
+	}
+
+	name = get_procedure_name (section, paragraph);
+	if (declare_procedure){
+		procedures_list = cb_text_list_add (procedures_list, name);
+		procedures_list_len++;
+	}
+	cb_str = cb_build_string (cobc_parse_strdup (name), strlen (name));
+	return CB_BUILD_FUNCALL_1 (prof_call_name, cb_str);
+}
+
+/* Returns the index of the procedure in the procedures_list, or -1 if not found */
+static int
+get_procedure_idx (const char* text)
+{
+	struct cb_text_list *l = procedures_list;
+	int i = 0;
+
+	while (!!l) {
+		if (!strcmp (text, l->text)) {
+			return i;
+		}
+		l = l->next;
+		i++;
+	}
+
+	return -1;
+}
+
 static void
 output_funcall (cb_tree x)
 {
@@ -4310,6 +4395,17 @@ output_funcall (cb_tree x)
 		return;
 	}
 
+	if ( cb_flag_prof && (
+		     p->name == cob_prof_enter_paragraph_str
+		     || p->name == cob_prof_exit_paragraph_str
+		     || p->name == cob_prof_enter_section_str
+		     || p->name == cob_prof_exit_section_str )) {
+		int proc_idx = get_procedure_idx( (char*) CB_STRING(p->argv[0])->data);
+		output ("%s (prof_info, %d)", p->name, proc_idx);
+		return;
+	}
+
+
 	screenptr = p->screenptr;
 	output ("%s (", p->name);
 	for (i = 0; i < p->argc; i++) {
@@ -7874,6 +7970,20 @@ output_goto_1 (cb_tree x)
 		output_move (cb_space, cb_debug_contents);
 	}
 
+	if (cb_flag_prof) {
+		/* If no section, then lb = section or exit label */
+
+		int idx;
+		if (lb->section) {
+			idx = get_procedure_idx ( get_procedure_name (lb->section, lb));
+		} else {
+			idx = get_procedure_idx ( get_procedure_name (lb, NULL));
+			/* If idx == -1 then GO TO exit, no need to generate a call */
+		}
+		if (idx != -1) { 
+			output_line("cob_prof_goto (prof_info, %d);", idx);
+		}
+	}
 	output_line ("goto %s%d;", CB_PREFIX_LABEL, lb->id);
 }
 
@@ -12183,6 +12293,9 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list)
 
 	/* Entry dispatch */
 	output_line ("/* Entry dispatch */");
+	if (cb_flag_prof) {
+		output_line("if (!prof_info) { prof_info = cob_prof_init (\"%s\", procedures_names, %d); }",	prog->orig_program_id, procedures_list_len);
+	}
 	if (cb_flag_stack_extended) {
 		/* entry marker = first frameptr is the one with
 		   an empty (instead of NULL) section name */;
@@ -13612,6 +13725,33 @@ output_header (const char *locbuff, const struct cb_program *cp)
 	}
 }
 
+static void
+output_cob_prof_data ()
+{
+	if (cb_flag_prof) {
+		struct cb_text_list *l = procedures_list;
+
+		output_local ("/* cob_prof data */\n\n");
+
+		output_local ("#include <libcob/cobprof.h>\n\n");
+
+		output_local ("static const char *procedures_names[%d] = {\n", procedures_list_len + 1);
+		while (l) {
+			output_local ("  \"%s\",\n", l->text);
+			l = l->next;
+		}
+		output_local ("  \"\"");
+		output_local ("};\n");
+
+		output_local ("static struct cobprof_info *prof_info;\n");
+
+		output_local ("\n/* End of cob_prof data */\n");
+
+		procedures_list = NULL;
+		procedures_list_len = 0;
+	}
+}
+
 void
 codegen (struct cb_program *prog, const char *translate_name)
 {
@@ -13887,6 +14027,7 @@ codegen_internal (struct cb_program *prog, const int subsequent_call)
 
 	output_local_base_cache ();
 	output_local_field_cache (prog);
+	output_cob_prof_data ();
 
 	/* Report data fields */
 	if (prog->report_storage) {

cobc/flag.def

@@ -254,3 +254,6 @@ CB_FLAG_ON (cb_diagnostics_show_caret, 1, "diagnostics-show-caret",
 
 CB_FLAG_ON (cb_diagnostics_show_line_numbers, 1, "diagnostics-show-line-numbers",
 	_("  -fno-diagnostics-show-line-numbers\tsuppress display of line numbers in diagnostics"))
+
+CB_FLAG (cb_flag_prof, 1, "prof",
+    _("  -fprof                enable profiling of the COBOL program"))

cobc/parser.y

@@ -407,6 +407,15 @@ emit_statement (cb_tree x)
 	}
 }
 
+static COB_INLINE COB_A_INLINE void
+emit_prof_call (enum cb_prof_call prof_call)
+{
+	if (cb_flag_prof) {
+		emit_statement (
+			cb_build_prof_call (prof_call, current_section, current_paragraph));
+	}
+}
+
 static void
 begin_statement_internal (enum cob_statement statement, const unsigned int term,
 	const char *file, const int line)
@@ -10927,12 +10936,14 @@ procedure_division:
 		if (current_paragraph->exit_label) {
 			emit_statement (current_paragraph->exit_label);
 		}
+		emit_prof_call (COB_PROF_EXIT_PARAGRAPH);
 		emit_statement (cb_build_perform_exit (current_paragraph));
 	}
 	if (current_section) {
 		if (current_section->exit_label) {
 			emit_statement (current_section->exit_label);
 		}
+		emit_prof_call (COB_PROF_EXIT_SECTION);
 		emit_statement (cb_build_perform_exit (current_section));
 	}
   }
@@ -10959,6 +10970,8 @@ procedure_division:
 	emit_statement (CB_TREE (current_section));
 	label = cb_build_reference ("MAIN PARAGRAPH");
 	current_paragraph = CB_LABEL (cb_build_label (label, NULL));
+	emit_prof_call (COB_PROF_ENTER_SECTION);
+	emit_prof_call (COB_PROF_ENTER_PARAGRAPH);
 	current_paragraph->flag_declaratives = !!in_declaratives;
 	current_paragraph->flag_skip_label = !!skip_statements;
 	current_paragraph->flag_dummy_paragraph = 1;
@@ -10969,6 +10982,10 @@ procedure_division:
   statements
   _dot_or_else_area_a
   _procedure_list
+  {
+	  emit_prof_call (COB_PROF_EXIT_PARAGRAPH);
+	  emit_prof_call (COB_PROF_EXIT_SECTION);
+  }
 ;
 
 _procedure_using_chaining:
@@ -11244,6 +11261,7 @@ _procedure_declaratives:
 		if (current_paragraph->exit_label) {
 			emit_statement (current_paragraph->exit_label);
 		}
+		emit_prof_call (COB_PROF_EXIT_PARAGRAPH);
 		emit_statement (cb_build_perform_exit (current_paragraph));
 		current_paragraph = NULL;
 	}
@@ -11252,6 +11270,7 @@ _procedure_declaratives:
 			emit_statement (current_section->exit_label);
 		}
 		current_section->flag_fatal_check = 1;
+		emit_prof_call (COB_PROF_EXIT_SECTION);
 		emit_statement (cb_build_perform_exit (current_section));
 		current_section = NULL;
 	}
@@ -11328,12 +11347,14 @@ section_header:
 		if (current_paragraph->exit_label) {
 			emit_statement (current_paragraph->exit_label);
 		}
+		emit_prof_call (COB_PROF_EXIT_PARAGRAPH);
 		emit_statement (cb_build_perform_exit (current_paragraph));
 	}
 	if (current_section) {
 		if (current_section->exit_label) {
 			emit_statement (current_section->exit_label);
 		}
+		emit_prof_call (COB_PROF_EXIT_SECTION);
 		emit_statement (cb_build_perform_exit (current_section));
 	}
 	if (current_program->flag_debugging && !in_debugging) {
@@ -11358,6 +11379,7 @@ section_header:
   _use_statement
   {
 	emit_statement (CB_TREE (current_section));
+	emit_prof_call (COB_PROF_ENTER_SECTION);
   }
 ;
 
@@ -11381,6 +11403,7 @@ paragraph_header:
 		if (current_paragraph->exit_label) {
 			emit_statement (current_paragraph->exit_label);
 		}
+		emit_prof_call (COB_PROF_EXIT_PARAGRAPH);
 		emit_statement (cb_build_perform_exit (current_paragraph));
 		if (current_program->flag_debugging && !in_debugging) {
 			emit_statement (cb_build_comment (
@@ -11400,13 +11423,15 @@ paragraph_header:
 		current_section->flag_skip_label = !!skip_statements;
 		current_section->xref.skip = 1;
 		emit_statement (CB_TREE (current_section));
+		emit_prof_call (COB_PROF_ENTER_SECTION);
 	}
 	current_paragraph = CB_LABEL (cb_build_label ($1, current_section));
 	current_paragraph->flag_declaratives = !!in_declaratives;
 	current_paragraph->flag_skip_label = !!skip_statements;
 	current_paragraph->flag_real_label = !in_debugging;
 	current_paragraph->segment = current_section->segment;
 	emit_statement (CB_TREE (current_paragraph));
+	emit_prof_call (COB_PROF_ENTER_PARAGRAPH);
   }
 ;
 
@@ -11509,6 +11534,7 @@ statements:
 		current_section->flag_declaratives = !!in_declaratives;
 		current_section->xref.skip = 1;
 		emit_statement (CB_TREE (current_section));
+		emit_prof_call (COB_PROF_ENTER_SECTION);
 	}
 	if (!current_paragraph) {
 		cb_tree label = cb_build_reference ("MAIN PARAGRAPH");
@@ -11522,6 +11548,7 @@ statements:
 		current_paragraph->flag_dummy_paragraph = 1;
 		current_paragraph->xref.skip = 1;
 		emit_statement (CB_TREE (current_paragraph));
+		emit_prof_call (COB_PROF_ENTER_PARAGRAPH);
 	}
 	if (check_headers_present (COBC_HD_PROCEDURE_DIVISION, 0, 0, 0) == 1) {
 		if (current_program->prog_type == COB_MODULE_TYPE_PROGRAM) {

cobc/tree.h

@@ -2597,6 +2597,18 @@ extern void		codegen (struct cb_program *, const char *);
 extern void		clear_local_codegen_vars (void);
 extern int		cb_wants_dump_comments;	/* likely to be removed later */
 
+
+enum cb_prof_call {
+	COB_PROF_EXIT_PARAGRAPH,
+	COB_PROF_EXIT_SECTION,
+	COB_PROF_ENTER_PARAGRAPH,
+	COB_PROF_ENTER_SECTION
+};
+
+extern cb_tree          cb_build_prof_call (enum cb_prof_call prof_fun,
+					    struct cb_label *section,
+					    struct cb_label *paragraph);
+
 #define CB_MEMCHK_NONE	0
 #define CB_MEMCHK_POINTER	(1 << 0)
 #define CB_MEMCHK_USING 	(1 << 1)

doc/ChangeLog

@@ -1,3 +1,7 @@
+2023-09-07  Emilien Lemaire <emilien.lemaire@ocamlpro.com>
+
+	* gnucobol.texi: document the profiling feature
+
 
 2023-07-10  Simon Sobisch <simonsobisch@gnu.org>