diff --git a/NEWS b/NEWS
index e7480c254..dc4699523 100644
--- a/NEWS
+++ b/NEWS
@@ -10,6 +10,13 @@ NEWS - user visible changes -*- outline -*-
the error output for format errors (for example invalid indicator column)
is now limitted to 5 per source file
+** Suppport for time profiling of modules, sections, paragraphs, entries
+ and external CALLs. This feature is activated by compiling the modules
+ to be profiled with -fprof, and then executing the code with environment
+ variable COB_PROF_ENABLE. The output is stored in a CSV file. Further
+ customization can be done using COB_PROF_FILE, COB_PROF_MAX_DEPTH and
+ COB_PROF_FORMAT
+
more work in progress
* Important Bugfixes
@@ -39,6 +46,12 @@ NEWS - user visible changes -*- outline -*-
INSPECT CONVERTING (and "simple" INSPECT REPLACING), in general
and especially if both from and to are constants
+* Changes in the COBOL runtime
+
+** more substitutions in environment variables: $f for executable filename,
+ $b for executable basename, $d for date in YYYYMMDD format, $t for time
+ in HHMMSS format (before, only $$ was available for pid)
+
* Known issues in 3.x
** testsuite:
diff --git a/bin/Makefile.am b/bin/Makefile.am
index 397cd8663..2d01e0198 100644
--- a/bin/Makefile.am
+++ b/bin/Makefile.am
@@ -20,8 +20,9 @@
# along with GnuCOBOL. If not, see .
bin_SCRIPTS = cob-config
-bin_PROGRAMS = cobcrun
+bin_PROGRAMS = cobcrun jorread
cobcrun_SOURCES = cobcrun.c
+jorread_SOURCES = jorread.c
dist_man_MANS = cobcrun.1 cob-config.1
COBCRUN = cobcrun$(EXEEXT)
@@ -31,6 +32,9 @@ AM_CFLAGS = $(CODE_COVERAGE_CFLAGS)
cobcrun_LDADD = $(top_builddir)/libcob/libcob.la \
$(top_builddir)/lib/libsupport.la \
$(PROGRAMS_LIBS) $(CODE_COVERAGE_LIBS)
+jorread_LDADD = $(top_builddir)/libcob/libcob.la \
+ $(top_builddir)/lib/libsupport.la \
+ $(PROGRAMS_LIBS) $(CODE_COVERAGE_LIBS)
# Add rules for code-coverage testing, as provided AX_CODE_COVERAGE
include $(top_srcdir)/aminclude_static.am
diff --git a/bin/jorread.c b/bin/jorread.c
new file mode 100644
index 000000000..c710a6f52
--- /dev/null
+++ b/bin/jorread.c
@@ -0,0 +1,254 @@
+/*
+ Copyright (C) 2024 Free Software Foundation, Inc.
+ Written by Fabrice LE FESSANT
+
+ This file is part of GnuCOBOL.
+
+ The GnuCOBOL module loader is free software: you can redistribute it
+ and/or modify it under the terms of the GNU General Public License
+ as published by the Free Software Foundation, either version 3 of the
+ License, or (at your option) any later version.
+
+ GnuCOBOL is distributed in the hope that it will be useful,
+ but WITHOUT 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
+ along with GnuCOBOL. If not, see .
+*/
+
+#include "tarstamp.h"
+#include "config.h"
+
+#include
+#include
+#include
+#include
+
+#ifdef HAVE_LOCALE_H
+#include
+#endif
+#ifdef HAVE_UNISTD_H
+#include
+#endif
+
+#include
+
+#include "../libcob/common.h"
+#include "../libcob/cobgetopt.h"
+
+#define GET_U16(addr) \
+ (*((cob_u16_t*) (addr)))
+
+#define GET_U32(addr) \
+ (*((cob_u32_t*) (addr)))
+
+#define GET_S16(addr) \
+ ( *((cob_s16_t*) (addr)))
+
+#define GET_S32(addr) \
+ (*((cob_s32_t*) (addr)))
+
+
+#define MAX_LEVELS 10
+
+static void jor_read (char *filename)
+{
+ FILE *fd = fopen (filename, "r");
+ char *buffer;
+ char header[JOR_HEADER_SIZE];
+ int len;
+ int version;
+ int size;
+ char *fields[256];
+ char *position;
+ int current_level;
+ char spaces[3+2*MAX_LEVELS];
+ int first_field[MAX_LEVELS];
+
+ memset (spaces, ' ', sizeof(spaces));
+ if ( !fd ){
+ fprintf (stderr, "Error: could not open file %s\n", filename);
+ exit (2);
+
+ }
+
+ len = fread (header, 1, JOR_HEADER_SIZE, fd);
+
+ if ( len1){
+ fprintf (stderr, "Error: file %s version %d too high\n",
+ filename, version);
+ exit (2);
+ }
+
+ buffer = cob_malloc (size);
+
+ len = fread (buffer, 1, size, fd);
+
+ if (len < size){
+ fprintf (stderr, "Warning: corrupted file %s, size %d < expected %d\n",
+ filename, len, size);
+ }
+
+ fprintf (stderr, "Reading file %s with content size %d\n",
+ filename, size);
+ position = buffer;
+ current_level = 0;
+
+ printf ("{\n");
+ first_field[0] = 1;
+
+ while (position - buffer < size){
+ int record_size = GET_U16 (position);
+ char *next_position = position+record_size;
+ int opcode = position[2];
+
+ switch (opcode){
+ case OPCODE_NEW_NAME: {
+ // fprintf (stderr, "opcode OPCODE_NEW_NAME\n");
+ int id = position[3];
+ int slen = position[4];
+ char *s = cob_malloc(slen+1);
+
+ memcpy (s, position+5, slen);
+ s[slen] = 0;
+ fields[id] = s;
+
+ // fprintf (stderr, "Field %d is '%s'\n", id, s);
+ break;
+ }
+ case OPCODE_LOCAL_FIELD: {
+ // fprintf (stderr, "opcode OPCODE_LOCAL_FIELD\n");
+ int level = position[3];
+ int id = position[4];
+ int type = position[5];
+
+ while (level < current_level){
+ spaces[current_level*2] = 0;
+ printf ("%s}", spaces);
+ spaces[current_level*2] = ' ';
+ current_level--;
+ }
+
+ if (!first_field[current_level]){
+ printf (",\n");
+ } else {
+ first_field[current_level] = 0;
+ }
+
+ spaces[2+current_level*2] = 0;
+ printf ("%s\"%s\" : ", spaces, fields[id]);
+ spaces[2+current_level*2] = ' ';
+
+ switch (type){
+ case TYPE_RECORD:
+ printf ("{\n");
+ current_level = level+1;
+ first_field[current_level] = 1;
+ break;
+ case TYPE_UINT8: {
+ cob_u8_t value = position[6];
+ printf ("%d", value);
+ break;
+ }
+ case TYPE_INT8: {
+ int value = position[6];
+ printf ("%d", value);
+ break;
+ }
+ case TYPE_UINT16: {
+ cob_u16_t value = GET_U16 (position+6);
+ printf ("%d", value);
+ break;
+ }
+ case TYPE_INT16: {
+ cob_s16_t value = GET_S16 (position+6);
+ printf ("%d", value);
+ break;
+ }
+ case TYPE_UINT32: {
+ cob_u32_t value = GET_U32 (position+6);
+ printf ("%d", value);
+ break;
+ }
+ case TYPE_INT32: {
+ cob_s32_t value = GET_S32 (position+6);
+ printf ("%d", value);
+ break;
+ }
+ case TYPE_FLOAT: {
+ double value = ((double*) (position+6))[0];
+ printf ("%f", value);
+ break;
+ }
+ case TYPE_STRING16: {
+ exit (2);
+ }
+ case TYPE_STRING8: {
+ int len = position[6];
+ char buf[256];
+
+ memcpy (buf, position+7, len);
+ buf[len]=0;
+ printf ("\"%s\"", buf);
+ break;
+ }
+ }
+ break;
+ }
+ default:
+ fprintf (stderr, "Error: file %s contains an unknown opcode %d",
+ filename, opcode);
+ }
+
+ position = next_position ;
+ // fprintf (stderr, "record_size = %d\n", record_size);
+ }
+
+ while (0 < current_level){
+ spaces[current_level*2] = 0;
+ printf ("%s}\n", spaces);
+ spaces[current_level*2] = ' ';
+ current_level--;
+ }
+
+ printf ("}\n");
+
+ fprintf (stderr, "done\n");
+ fclose (fd);
+}
+
+int main (int argc, char** argv)
+{
+
+ int i;
+
+ for (i=1; i and Emilien Lemaire
+
+ * parser.y: generate calls to "cob_prof_function_call" in the
+ parsetree when profiling is unabled, when entering/leaving
+ profiled blocks
+ * flag.def: add `-fprof` to enable profiling
+ * codegen.c: handle profiling code generation under the
+ cb_flag_prof guard
2023-11-29 Fabrice Le Fessant
diff --git a/cobc/codegen.c b/cobc/codegen.c
index 293e3b4e3..613675afb 100644
--- a/cobc/codegen.c
+++ b/cobc/codegen.c
@@ -4318,6 +4318,186 @@ output_funcall_item (cb_tree x, const int i, unsigned int func_nolitcast)
}
+
+/* Use constant strings to replace string comparisons by more
+ * efficient pointer comparisons */
+static const char *cob_prof_function_call_str = "cob_prof_function_call";
+
+/* Allocate a procedure description record and add it at the end of
+ * the procedure_list of the current program. The index of the
+ * procedure will be the position in the list. There is an invariant
+ * that 0 is reserved for the record of the program module. */
+static int
+procedure_list_add (
+ struct cb_program *program,
+ enum cob_prof_procedure_kind kind,
+ const char *text,
+ int section,
+ const char *file,
+ int line
+ )
+{
+ struct cb_procedure_list *p;
+ int ret = program->procedure_list_len ;
+
+ p = cobc_main_malloc (sizeof (struct cb_procedure_list));
+ if (text){ p->proc.text = cobc_main_strdup (text); }
+ p->proc.kind = kind;
+ p->proc.file = file;
+ p->proc.line = line;
+ p->proc.section = section;
+ p->next = NULL;
+
+ if (program->procedure_list == NULL){
+ program->procedure_list = p;
+ } else {
+ program->procedure_list_last->next = p;
+ }
+ program->procedure_list_last = p;
+
+ program->procedure_list_len++;
+ return ret;
+}
+
+void
+cb_prof_procedure_division (struct cb_program *program,
+ const char *source_file,
+ int source_line)
+{
+ /* invariant: program always has index 0 */
+ procedure_list_add (
+ program,
+ COB_PROF_PROCEDURE_MODULE,
+ program->program_id,
+ 0,
+ source_file,
+ source_line);
+}
+
+/* Returns a tree node for a funcall to one of the profiling
+ functions, with the index of the procedure as argument (and a second
+ argument for the entry point if meaningful). If the program, section
+ or paragraph are being entered for the first time, register them into
+ the procedure_list of the program.
+
+ To avoid lookups, the current section and current paragraph are kept
+ in the program record for immediate use when exiting.
+*/
+cb_tree
+cb_build_prof_call (enum cb_prof_call prof_call,
+ struct cb_program *program,
+ struct cb_label *section,
+ struct cb_label *paragraph,
+ const char *entry,
+ cb_tree location)
+{
+ const char *func_name = cob_prof_function_call_str;
+ int func_arg1;
+ int func_arg2 = -1;
+
+ switch (prof_call){
+
+ case COB_PROF_ENTER_SECTION:
+
+ /* allocate section record and remember current section */
+ program->prof_current_section =
+ procedure_list_add (
+ program,
+ COB_PROF_PROCEDURE_SECTION,
+ section->name,
+ /* the current section will have
+ * procedure_list_list as index */
+ program->procedure_list_len,
+ section->common.source_file,
+ section->common.source_line);
+ program->prof_current_paragraph = -1;
+ func_arg1 = program->prof_current_section;
+ break;
+
+ case COB_PROF_ENTER_PARAGRAPH:
+
+ /* allocate section record and remember current section */
+ program->prof_current_paragraph =
+ procedure_list_add (
+ program,
+ COB_PROF_PROCEDURE_PARAGRAPH,
+ paragraph->name,
+ program->prof_current_section,
+ paragraph->common.source_file,
+ paragraph->common.source_line);
+ func_arg1 = program->prof_current_paragraph;
+ break;
+
+ /* In the case of an ENTRY statement, add code before
+ * to the falling-through paragraph to avoid
+ * re-registering the entry into the paragraph. */
+ case COB_PROF_STAYIN_PARAGRAPH:
+
+ func_arg1 = program->prof_current_paragraph;
+ break;
+
+ case COB_PROF_USE_PARAGRAPH_ENTRY:
+
+ func_arg1 = program->prof_current_paragraph;
+ func_arg2 =
+ procedure_list_add (
+ program,
+ COB_PROF_PROCEDURE_ENTRY,
+ entry,
+ /* section field of entry is in fact its paragraph */
+ program->prof_current_paragraph,
+ location->source_file,
+ location->source_line);
+ break;
+
+ case COB_PROF_EXIT_PARAGRAPH:
+
+ func_arg1 = program->prof_current_paragraph;
+ /* Do not reinitialize, because we may have several of these
+ EXIT_PARAGRAPH, for example at EXIT SECTION.
+ program->prof_current_paragraph = -1; */
+ break;
+
+ case COB_PROF_EXIT_SECTION:
+
+ func_arg1 = program->prof_current_section;
+ /* reset current paragraph and section */
+ program->prof_current_section = -1;
+ program->prof_current_paragraph = -1;
+ break;
+
+ case COB_PROF_ENTER_CALL:
+
+ /* allocate call record and remember current call */
+ program->prof_current_call =
+ procedure_list_add (
+ program,
+ COB_PROF_PROCEDURE_CALL,
+ NULL,
+ program->prof_current_paragraph,
+ paragraph->common.source_file,
+ paragraph->common.source_line);
+ func_arg1 = program->prof_current_call;
+ break;
+
+ case COB_PROF_EXIT_CALL:
+
+ /* We need to patch the last procedure to add the callee name and loc */
+ program->procedure_list_last->proc.text = cobc_main_strdup (entry);
+ program->procedure_list_last->proc.file = location->source_file;
+ program->procedure_list_last->proc.line = location->source_line;
+
+ func_arg1 = program->prof_current_call;
+ program->prof_current_call = -1;
+ break;
+
+ }
+ if (func_arg2 < 0){
+ return CB_BUILD_FUNCALL_2 (func_name, cb_int (prof_call), cb_int (func_arg1));
+ }
+ return CB_BUILD_FUNCALL_3 (func_name, cb_int (prof_call), cb_int (func_arg1), cb_int (func_arg2));
+}
+
static void
output_funcall (cb_tree x)
{
@@ -4333,6 +4513,55 @@ output_funcall (cb_tree x)
return;
}
+ if ( cb_flag_prof && p->name == cob_prof_function_call_str ) {
+
+ int proc_idx ;
+
+ switch ( CB_INTEGER (p->argv[0])->val ){
+
+ case COB_PROF_EXIT_PARAGRAPH:
+ proc_idx = CB_INTEGER(p->argv[1])->val;
+ output ("cob_prof_exit_procedure (prof_info, %d)", proc_idx);
+ break;
+ case COB_PROF_ENTER_SECTION:
+ proc_idx = CB_INTEGER(p->argv[1])->val;
+ output ("cob_prof_enter_section (prof_info, %d)", proc_idx);
+ break;
+ case COB_PROF_EXIT_SECTION:
+ proc_idx = CB_INTEGER(p->argv[1])->val;
+ output ("cob_prof_exit_section (prof_info, %d)", proc_idx);
+ break;
+ case COB_PROF_ENTER_CALL:
+ proc_idx = CB_INTEGER(p->argv[1])->val;
+ output ("cob_prof_enter_procedure (prof_info, %d)", proc_idx);
+ break;
+ case COB_PROF_EXIT_CALL:
+ proc_idx = CB_INTEGER(p->argv[1])->val;
+ output ("cob_prof_exit_procedure (prof_info, %d)", proc_idx);
+ break;
+ case COB_PROF_ENTER_PARAGRAPH:
+ proc_idx = CB_INTEGER(p->argv[1])->val;
+ output ("cob_prof_enter_procedure (prof_info, %d);\n", proc_idx);
+ output (" cob_prof_fallthrough_entry = 0");
+ break;
+ case COB_PROF_USE_PARAGRAPH_ENTRY: {
+ int paragraph_idx = CB_INTEGER(p->argv[1])->val;
+ int entry_idx = CB_INTEGER(p->argv[2])->val;
+ output ("if (!cob_prof_fallthrough_entry){\n");
+ output ("\tcob_prof_use_paragraph_entry (prof_info, %d, %d);\n",
+ paragraph_idx, entry_idx);
+ output (" }\n");
+ output (" cob_prof_fallthrough_entry = 0");
+ break;
+ }
+ case COB_PROF_STAYIN_PARAGRAPH:
+ output ("cob_prof_fallthrough_entry = 1");
+ break;
+ }
+ return ;
+ }
+
+
screenptr = p->screenptr;
output ("%s (", p->name);
for (i = 0; i < p->argc; i++) {
@@ -7925,6 +8154,13 @@ output_goto (struct cb_goto *p)
struct cb_field *f;
int i;
+ if (cb_flag_prof) {
+ /* Output this only if we are exiting the paragraph... */
+ if ( !(p->flags & CB_GOTO_FLAG_SAME_PARAGRAPH) ){
+ output_line ("cob_prof_goto (prof_info);");
+ }
+ }
+
i = 1;
if (p->depending) {
/* Check for debugging on the DEPENDING item */
@@ -12206,6 +12442,19 @@ 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) {");
+ output_line (
+ "\tprof_info = cob_prof_init_module (module, prof_procedures, %d);",
+ prog->procedure_list_len);
+ output_line ("}");
+
+ /* Prevent CANCEL from dlclose() the module, because
+ we keep pointers to static data there. */
+ output_line ("if (prof_info){ module->flag_no_phys_canc = 1; }");
+
+ output_line ("cob_prof_enter_procedure (prof_info, 0);");
+ }
if (cb_flag_stack_extended) {
/* entry marker = first frameptr is the one with
an empty (instead of NULL) section name */;
@@ -12300,7 +12549,9 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list)
output_newline ();
}
}
-
+ if (cb_flag_prof){
+ output_line ("cob_prof_exit_procedure (prof_info, 0);");
+ }
if (!prog->flag_recursive) {
output_line ("/* Decrement module active count */");
output_line ("if (module->module_active) {");
@@ -13629,6 +13880,45 @@ output_header (const char *locbuff, const struct cb_program *cp)
}
}
+static void
+output_cob_prof_data ( struct cb_program * program )
+{
+ if (cb_flag_prof) {
+ struct cb_procedure_list *l;
+ char sep = ' ';
+
+ output_local ("/* cob_prof data */\n\n");
+
+ output_local ("static const int nprocedures = %d;\n",
+ program->procedure_list_len);
+ output_local ("static struct cob_prof_procedure prof_procedures[%d] = {\n",
+ program->procedure_list_len);
+ sep = ' ';
+ for (l = program->procedure_list; l; l=l->next) {
+ output_local (" %c { \"%s\", \"%s\", %d, %d, %d }\n",
+ sep,
+ l->proc.text,
+ l->proc.file,
+ l->proc.line,
+ l->proc.section,
+ l->proc.kind
+ );
+ sep = ',';
+ }
+ output_local ("};\n");
+
+ output_local ("static int cob_prof_fallthrough_entry = 0;\n");
+ output_local ("static struct cob_prof_module *prof_info;\n");
+
+ output_local ("\n/* End of cob_prof data */\n");
+
+ program->procedure_list = NULL;
+ program->procedure_list_len = 0;
+ program->prof_current_section = -1;
+ program->prof_current_paragraph = -1;
+ }
+}
+
void
codegen (struct cb_program *prog, const char *translate_name)
{
@@ -13904,6 +14194,7 @@ codegen_internal (struct cb_program *prog, const int subsequent_call)
output_local_base_cache ();
output_local_field_cache (prog);
+ output_cob_prof_data (prog);
/* Report data fields */
if (prog->report_storage) {
diff --git a/cobc/flag.def b/cobc/flag.def
index d362ee99b..58c84025b 100644
--- a/cobc/flag.def
+++ b/cobc/flag.def
@@ -258,3 +258,7 @@ CB_FLAG_ON (cb_diagnostics_show_line_numbers, 1, "diagnostics-show-line-numbers"
CB_FLAG (cb_diagnostics_absolute_paths, 1, "diagnostics-absolute-paths",
_(" -fdiagnostics-absolute-paths\tprint absolute paths in diagnostics"))
+
+CB_FLAG (cb_flag_prof, 1, "prof",
+ _(" -fprof enable profiling of the COBOL program"))
+
diff --git a/cobc/parser.y b/cobc/parser.y
index 3b463150b..644c26744 100644
--- a/cobc/parser.y
+++ b/cobc/parser.y
@@ -406,6 +406,21 @@ emit_statement (cb_tree x)
}
}
+static COB_INLINE COB_A_INLINE void
+emit_prof_call (enum cb_prof_call prof_call, const char* entry, cb_tree location)
+{
+ if (cb_flag_prof) {
+ emit_statement (
+ cb_build_prof_call (prof_call,
+ current_program,
+ current_section,
+ current_paragraph,
+ entry,
+ location
+ ));
+ }
+}
+
static void
begin_statement_internal (enum cob_statement statement, const unsigned int term,
const char *file, const int line)
@@ -2104,8 +2119,8 @@ check_preceding_tallying_phrases (const enum tallying_phrase phrase)
previous_tallying_phrase = phrase;
}
-static int
-is_recursive_call (cb_tree target)
+static const char *
+get_call_target (cb_tree target)
{
const char *target_name = "";
@@ -2116,7 +2131,13 @@ is_recursive_call (cb_tree target)
target_name = CB_PROTOTYPE (cb_ref (target))->ext_name;
}
- return !strcmp (target_name, current_program->orig_program_id);
+ return target_name ;
+}
+
+static int
+is_recursive_call (const char *call_target)
+{
+ return !strcmp ( call_target, current_program->orig_program_id);
}
static cb_tree
@@ -10884,6 +10905,12 @@ procedure_division:
cobc_in_procedure = 1U;
cb_set_system_names ();
last_source_line = cb_source_line;
+
+ cb_prof_procedure_division (
+ current_program,
+ cb_source_file,
+ cb_source_line
+ );
}
DIVISION
_mnemonic_conv _conv_linkage _procedure_using_chaining _procedure_returning
@@ -10926,12 +10953,14 @@ procedure_division:
if (current_paragraph->exit_label) {
emit_statement (current_paragraph->exit_label);
}
+ emit_prof_call (COB_PROF_EXIT_PARAGRAPH, NULL, NULL);
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, NULL, NULL);
emit_statement (cb_build_perform_exit (current_section));
}
}
@@ -10958,6 +10987,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, NULL, NULL);
+ emit_prof_call (COB_PROF_ENTER_PARAGRAPH, NULL, NULL);
current_paragraph->flag_declaratives = !!in_declaratives;
current_paragraph->flag_skip_label = !!skip_statements;
current_paragraph->flag_dummy_paragraph = 1;
@@ -10968,6 +10999,10 @@ procedure_division:
statements
_dot_or_else_area_a
_procedure_list
+ {
+ emit_prof_call (COB_PROF_EXIT_PARAGRAPH, NULL, NULL);
+ emit_prof_call (COB_PROF_EXIT_SECTION, NULL, NULL);
+ }
;
_procedure_using_chaining:
@@ -11243,6 +11278,7 @@ _procedure_declaratives:
if (current_paragraph->exit_label) {
emit_statement (current_paragraph->exit_label);
}
+ emit_prof_call (COB_PROF_EXIT_PARAGRAPH, NULL, NULL);
emit_statement (cb_build_perform_exit (current_paragraph));
current_paragraph = NULL;
}
@@ -11251,6 +11287,7 @@ _procedure_declaratives:
emit_statement (current_section->exit_label);
}
current_section->flag_fatal_check = 1;
+ emit_prof_call (COB_PROF_EXIT_SECTION, NULL, NULL);
emit_statement (cb_build_perform_exit (current_section));
current_section = NULL;
}
@@ -11327,12 +11364,14 @@ section_header:
if (current_paragraph->exit_label) {
emit_statement (current_paragraph->exit_label);
}
+ emit_prof_call (COB_PROF_EXIT_PARAGRAPH, NULL, NULL);
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, NULL, NULL);
emit_statement (cb_build_perform_exit (current_section));
}
if (current_program->flag_debugging && !in_debugging) {
@@ -11357,6 +11396,7 @@ section_header:
_use_statement
{
emit_statement (CB_TREE (current_section));
+ emit_prof_call (COB_PROF_ENTER_SECTION, NULL, NULL);
}
;
@@ -11380,6 +11420,7 @@ paragraph_header:
if (current_paragraph->exit_label) {
emit_statement (current_paragraph->exit_label);
}
+ emit_prof_call (COB_PROF_EXIT_PARAGRAPH, NULL, NULL);
emit_statement (cb_build_perform_exit (current_paragraph));
if (current_program->flag_debugging && !in_debugging) {
emit_statement (cb_build_comment (
@@ -11399,6 +11440,7 @@ 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, NULL, NULL);
}
current_paragraph = CB_LABEL (cb_build_label ($1, current_section));
current_paragraph->flag_declaratives = !!in_declaratives;
@@ -11406,6 +11448,7 @@ paragraph_header:
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, NULL, NULL);
}
;
@@ -11508,6 +11551,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, NULL, NULL);
}
if (!current_paragraph) {
cb_tree label = cb_build_reference ("MAIN PARAGRAPH");
@@ -11521,6 +11565,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, NULL, NULL);
}
if (check_headers_present (COBC_HD_PROCEDURE_DIVISION, 0, 0, 0) == 1) {
if (current_program->prog_type == COB_MODULE_TYPE_PROGRAM) {
@@ -11622,7 +11667,7 @@ statement:
sprintf (name, "L$%d", next_label_id);
label = cb_build_reference (name);
next_label_list = cb_list_add (next_label_list, label);
- emit_statement (cb_build_goto (label, NULL));
+ emit_statement (cb_build_goto (label, NULL, CB_GOTO_FLAG_NONE));
} else {
cb_tree note = cb_build_comment ("skipped NEXT SENTENCE");
emit_statement (note);
@@ -12412,6 +12457,7 @@ _proceed_to: | PROCEED TO ;
call_statement:
CALL
{
+ emit_prof_call (COB_PROF_ENTER_CALL, NULL, NULL);
begin_statement (STMT_CALL, TERM_CALL);
cobc_cs_check = CB_CS_CALL;
call_nothing = 0;
@@ -12437,10 +12483,11 @@ call_body:
{
int call_conv = 0;
int call_conv_local = 0;
+ const char *target_name = get_call_target ($3);
if (current_program->prog_type == COB_MODULE_TYPE_PROGRAM
&& !current_program->flag_recursive
- && is_recursive_call ($3)) {
+ && is_recursive_call (target_name)) {
cb_tree x = CB_TREE (current_statement);
if (cb_verify_x (x, cb_self_call_recursive, _("CALL to own PROGRAM-ID"))) {
cb_note_x (cb_warn_dialect, x, _("assuming RECURSIVE attribute"));
@@ -12504,6 +12551,9 @@ call_body:
}
cb_emit_call ($3, $7, $8, CB_PAIR_X ($9), CB_PAIR_Y ($9),
cb_int (call_conv), $2, $5);
+ emit_prof_call (COB_PROF_EXIT_CALL,
+ target_name[0] == 0 ? "(dynamic)" : target_name,
+ $3);
}
;
@@ -13885,6 +13935,7 @@ entry_statement:
entry
{
check_unreached = 0;
+ emit_prof_call (COB_PROF_STAYIN_PARAGRAPH, NULL, NULL);
begin_statement (STMT_ENTRY, 0);
current_statement->flag_no_based = 1;
}
@@ -13923,6 +13974,8 @@ entry_body:
if (!cobc_check_valid_name ((char *)(CB_LITERAL ($2)->data), ENTRY_NAME)) {
emit_entry ((char *)(CB_LITERAL ($2)->data), 1, $4, call_conv);
}
+ emit_prof_call (COB_PROF_USE_PARAGRAPH_ENTRY,
+ (char *)(CB_LITERAL ($2)->data), $2 );
}
}
;
@@ -14415,7 +14468,7 @@ exit_body:
CB_LABEL (plabel)->flag_dummy_exit = 1;
}
current_statement->statement = STMT_EXIT_PERFORM_CYCLE;
- cb_emit_goto (CB_LIST_INIT (p->cycle_label), NULL);
+ cb_emit_goto (CB_LIST_INIT (p->cycle_label), NULL, CB_GOTO_FLAG_SAME_PARAGRAPH);
check_unreached = 1;
}
}
@@ -14438,7 +14491,7 @@ exit_body:
CB_LABEL (plabel)->flag_dummy_exit = 1;
}
current_statement->statement = STMT_EXIT_PERFORM;
- cb_emit_goto (CB_LIST_INIT (p->exit_label), NULL);
+ cb_emit_goto (CB_LIST_INIT (p->exit_label), NULL, CB_GOTO_FLAG_SAME_PARAGRAPH);
check_unreached = 1;
}
}
@@ -14459,7 +14512,7 @@ exit_body:
CB_LABEL (plabel)->flag_dummy_exit = 1;
}
current_statement->statement = STMT_EXIT_SECTION;
- cb_emit_goto (CB_LIST_INIT (current_section->exit_label), NULL);
+ cb_emit_goto (CB_LIST_INIT (current_section->exit_label), NULL, CB_GOTO_FLAG_NONE);
check_unreached = 1;
}
}
@@ -14480,7 +14533,7 @@ exit_body:
CB_LABEL (plabel)->flag_dummy_exit = 1;
}
current_statement->statement = STMT_EXIT_PARAGRAPH;
- cb_emit_goto (CB_LIST_INIT (current_paragraph->exit_label), NULL);
+ cb_emit_goto (CB_LIST_INIT (current_paragraph->exit_label), NULL, CB_GOTO_FLAG_SAME_PARAGRAPH);
check_unreached = 1;
}
}
@@ -14565,13 +14618,13 @@ goto_statement:
go_body:
_to procedure_name_list _goto_depending
{
- cb_emit_goto ($2, $3);
+ cb_emit_goto ($2, $3, CB_GOTO_FLAG_NONE);
start_debug = save_debug;
}
| _to ENTRY entry_name_list _goto_depending
{
if (cb_verify (cb_goto_entry, "ENTRY FOR GO TO")) {
- cb_emit_goto ($3, $4);
+ cb_emit_goto ($3, $4, CB_GOTO_FLAG_NONE);
}
start_debug = save_debug;
}
diff --git a/cobc/tree.c b/cobc/tree.c
index 0e945aeaf..695303c93 100644
--- a/cobc/tree.c
+++ b/cobc/tree.c
@@ -2196,6 +2196,11 @@ cb_build_program (struct cb_program *last_program, const int nest_level)
if (cb_call_extfh) {
p->extfh = cobc_parse_strdup (cb_call_extfh);
}
+
+ p->prof_current_section = -1;
+ p->prof_current_paragraph = -1;
+ p->prof_current_call = -1;
+
/* Save current program as actual at it's level */
container_progs[nest_level] = p;
if (nest_level
@@ -6656,7 +6661,7 @@ cb_build_alter (const cb_tree source, const cb_tree target)
/* GO TO */
cb_tree
-cb_build_goto (const cb_tree target, const cb_tree depending)
+cb_build_goto (const cb_tree target, const cb_tree depending, int flags)
{
struct cb_goto *p;
@@ -6664,6 +6669,7 @@ cb_build_goto (const cb_tree target, const cb_tree depending)
sizeof (struct cb_goto));
p->target = target;
p->depending = depending;
+ p->flags = flags;
return CB_TREE (p);
}
diff --git a/cobc/tree.h b/cobc/tree.h
index a9d668772..1763f103f 100644
--- a/cobc/tree.h
+++ b/cobc/tree.h
@@ -1432,10 +1432,14 @@ struct cb_alter {
/* GO TO */
+#define CB_GOTO_FLAG_NONE 0
+#define CB_GOTO_FLAG_SAME_PARAGRAPH 1
+
struct cb_goto {
struct cb_tree_common common; /* Common values */
cb_tree target; /* Procedure name(s) */
cb_tree depending; /* DEPENDING */
+ int flags; /* Goto flags */
};
#define CB_GOTO(x) (CB_TREE_CAST (CB_TAG_GOTO, struct cb_goto, x))
@@ -1798,6 +1802,11 @@ struct cb_ml_generate_tree {
#define CB_ML_TREE(x) (CB_TREE_CAST (CB_TAG_ML_TREE, struct cb_ml_generate_tree, x))
#define CB_ML_TREE_P(x) (CB_TREE_TAG (x) == CB_TAG_ML_TREE)
+struct cb_procedure_list {
+ struct cb_procedure_list *next;
+ struct cob_prof_procedure proc;
+};
+
/* Program */
struct literal_list {
@@ -1905,6 +1914,14 @@ struct cb_program {
cb_tree entry_convention; /* ENTRY convention / PROCEDURE convention */
struct literal_list *decimal_constants;
+ /* Data and functions used for profiling */
+ struct cb_procedure_list *procedure_list;
+ struct cb_procedure_list *procedure_list_last;
+ int procedure_list_len;
+ int prof_current_section;
+ int prof_current_paragraph;
+ int prof_current_call;
+
unsigned int flag_main : 1; /* Gen main function */
unsigned int flag_common : 1; /* COMMON PROGRAM */
unsigned int flag_initial : 1; /* INITIAL PROGRAM */
@@ -2189,7 +2206,7 @@ extern cb_tree cb_build_alter (const cb_tree, const cb_tree);
extern cb_tree cb_build_cancel (const cb_tree);
-extern cb_tree cb_build_goto (const cb_tree, const cb_tree);
+extern cb_tree cb_build_goto (const cb_tree, const cb_tree, int flags);
extern cb_tree cb_build_if (const cb_tree, const cb_tree,
const cb_tree, const enum cob_statement);
@@ -2463,7 +2480,7 @@ extern void cb_emit_divide (cb_tree, cb_tree,
extern void cb_emit_evaluate (cb_tree, cb_tree);
-extern void cb_emit_goto (cb_tree, cb_tree);
+extern void cb_emit_goto (cb_tree, cb_tree, int);
extern void cb_emit_exit (const unsigned int);
extern void cb_emit_if (cb_tree, cb_tree, cb_tree);
@@ -2611,6 +2628,29 @@ 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_ENTER_SECTION,
+ COB_PROF_ENTER_PARAGRAPH,
+ COB_PROF_STAYIN_PARAGRAPH,
+ COB_PROF_USE_PARAGRAPH_ENTRY,
+ COB_PROF_EXIT_PARAGRAPH,
+ COB_PROF_EXIT_SECTION,
+ COB_PROF_ENTER_CALL,
+ COB_PROF_EXIT_CALL
+};
+
+extern cb_tree cb_build_prof_call (enum cb_prof_call prof_fun,
+ struct cb_program *program,
+ struct cb_label *section,
+ struct cb_label *paragraph,
+ const char *entry,
+ cb_tree location);
+
+extern void cb_prof_procedure_division (struct cb_program *program,
+ const char *file,
+ int line);
+
#define CB_MEMCHK_NONE 0
#define CB_MEMCHK_POINTER (1 << 0)
#define CB_MEMCHK_USING (1 << 1)
diff --git a/cobc/typeck.c b/cobc/typeck.c
index 7ca5db3f7..7a7c5434c 100644
--- a/cobc/typeck.c
+++ b/cobc/typeck.c
@@ -10054,7 +10054,7 @@ cb_emit_free (cb_tree vars)
/* GO TO statement */
void
-cb_emit_goto (cb_tree target, cb_tree depending)
+cb_emit_goto (cb_tree target, cb_tree depending, int flags)
{
if (target == cb_error_node) {
return;
@@ -10065,14 +10065,14 @@ cb_emit_goto (cb_tree target, cb_tree depending)
/* GO TO procedure-name ... DEPENDING ON numeric-identifier and
GO TO ENTRY entry-name ... DEPENDING ON numeric-identifier */
cb_emit_incompat_data_checks (depending);
- cb_emit (cb_build_goto (target, depending));
+ cb_emit (cb_build_goto (target, depending, flags));
} else if (CB_CHAIN (target)) {
cb_error_x (CB_TREE (current_statement),
_("GO TO with multiple procedure-names"));
} else {
/* GO TO procedure-name and
GO TO ENTRY entry-name */
- cb_emit (cb_build_goto (CB_VALUE (target), NULL));
+ cb_emit (cb_build_goto (CB_VALUE (target), NULL, flags));
}
}
@@ -10080,9 +10080,9 @@ void
cb_emit_exit (const unsigned int goback)
{
if (goback) {
- cb_emit (cb_build_goto (cb_int1, NULL));
+ cb_emit (cb_build_goto (cb_int1, NULL, CB_GOTO_FLAG_NONE));
} else {
- cb_emit (cb_build_goto (NULL, NULL));
+ cb_emit (cb_build_goto (NULL, NULL, CB_GOTO_FLAG_NONE));
}
}
diff --git a/config/runtime.cfg b/config/runtime.cfg
index a8e22276e..5f4b2aabf 100644
--- a/config/runtime.cfg
+++ b/config/runtime.cfg
@@ -217,6 +217,65 @@
# Example: COB_CURRENT_DATE "2026/03/16 16:40:52"
# current_date YYYYMMDDHHMMSS+01:00
+# Environment name: COB_JOR_FILE
+# Parameter name: jor_file
+# Purpose: to define where COBOL JOR files should go
+# Type: string where $$ is replaced by process id, $b executable
+# basename, $f executable filename, $d date yyyymmdd,
+# $t time hhmmss
+# Default: cob-jor-$b-$$-$d-$t.jor
+# Example: JOR_FILE ${HOME}/myprog-$$.jor
+
+# Environment name: COB_JOR_ENABLE
+# Parameter name: jor_enable
+# Purpose: to enable generation of JOR files during execution
+# Type: boolean
+# Default: false
+# Example: JOR_ENABLE yes
+
+# Environment name: COB_JOR_MAX_SIZE
+# Parameter name: jor_max_size
+# Purpose: the maximal size of a JOR file.
+# Type: integer
+# Default: 8192
+# Example: JOR_MAX_SIZE 8192
+
+# Environment name: COB_PROF_FILE
+# Parameter name: prof_file
+# Purpose: to define where COBOL profiling output should go
+# Type: string where $$ is replaced by process id, $b executable
+# basename, $f executable filename, $d date yyyymmdd,
+# $t time hhmmss
+# Default: cob-prof-$b-$$-$d-$t.csv
+# Example: PROF_FILE ${HOME}/$$-prof.csv
+
+# Environment name: COB_PROF_ENABLE
+# Parameter name: prof_enable
+# Purpose: to enable profiling for modules compiled with profiling
+# Type: boolean
+# Default: false
+# Example: PROF_ENABLE yes
+
+# Environment name: COB_PROF_MAX_DEPTH
+# Parameter name: prof_max_depth
+# Purpose: the number of sections and paragraphs that can be nested;
+# if the nesting level is higher than this threshold,
+# profiling is disabled automatically
+# Type: integer
+# Default: 8192
+# Example: PROF_MAX_DEPTH 8192
+
+# Environment name: COB_PROF_FORMAT
+# Parameter name: prof_format
+# Purpose: to define the format of the columns in the profiling CSV file.
+# Type: string a comma separated list of fields, with %m for module,
+# %s for section, %p for paragraph, %e for entry, %w for
+# location, %k for kind (PROGRAM,SECTION,PARAGRAPH,ENTRY)
+# %f for file, %i for PID, %t for time in nano-seconds,
+# %h for human-readable time, %n for number of calls
+# Default: %m,%s,%p,%e,%w,%k,%t,%h,%n
+# Example: COB_PROF_FORMAT %m,%s,%p,%e,%w,%k,%t,%h,%n
+
#
## Call environment
#
diff --git a/doc/ChangeLog b/doc/ChangeLog
index 6370af4f0..77aded81c 100644
--- a/doc/ChangeLog
+++ b/doc/ChangeLog
@@ -1,3 +1,7 @@
+2023-09-07 Emilien Lemaire
+
+ * gnucobol.texi: document the profiling feature
+
2023-07-10 Simon Sobisch
diff --git a/doc/gnucobol.texi b/doc/gnucobol.texi
index 0ed1f9f0a..b5edcdc10 100644
--- a/doc/gnucobol.texi
+++ b/doc/gnucobol.texi
@@ -87,6 +87,7 @@ Welcome to the GnuCOBOL @value{VERSION} manual.
* Customize:: Customizing the compiler
* Optimize:: Optimizing your program
* Debug:: Debugging your program
+* Profiling:: Profiling your program
* Extensions:: Non-standard extensions
* System Routines:: Additional routines
* Appendices:: List of supported features and options,
@@ -156,6 +157,10 @@ Debug
* Core Dumps:: Core Dumps
* Trace:: Tracing execution
+Profiling
+* Profiling options:: Profiling options
+* Profiling results:: Profiling results
+
Extensions
* SELECT:: SELECT ASSIGN TO.
@@ -1718,7 +1723,7 @@ machine. Set the config option @code{binary-byteorder} to
In addition, setting the option @code{binary-size} to @code{2-4-8} or
@code{1-2-4-8} is more efficient than others.
-@node Debug, Extensions, Optimize, Top
+@node Debug, Profiling, Optimize, Top
@chapter Debug
@menu
@@ -1779,7 +1784,100 @@ Tracing program execution, either in general or in specific parts can be enabled
@exampleindent 0
-@node Extensions, System Routines, Debug, Top
+@node Profiling, Extensions, Debug, Top
+@chapter Profiling COBOL
+@cindex Profiling
+@cindex Profiling your program
+
+@menu
+* Profiling options:: Profiling options
+* Profiling results:: Profiling results
+@end menu
+
+@node Profiling options
+@section Profiling options
+
+Profiling is enabled with the @code{-fprof} flag while compiling a
+COBOL module. Only modules that have been compiled with profiling
+enabled can be later profiled.
+
+Then executing your program with @env{COB_PROF_ENABLE=1} will
+automatically profile the module(s) and generate a CSV result file.
+Note that physical @code{CANCEL} is disabled when profiling is
+enabled, because some profiling information in the module needs to
+remain available until the end of the program.
+
+By default, this file is called
+@code{cob-prof--.csv}, but this name can be
+configured using @env{COB_PROF_FILE}.
+
+Some environment variables (and the corresponding options in the
+runtime configuration) can be used to tune the behavior of profiling
+during execution: @code{COB_PROF_FILE}, @code{COB_PROF_ENABLE}
+and @code{COB_PROF_MAX_DEPTH}, @code{COB_PROF_FORMAT}
+@pxref{Appendix I, Runtime Configuration, Runtime Configuration} for
+more information.
+
+
+@node Profiling results
+@section Profiling results
+@cindex Profiling results
+@cindex How to interpret the profiling results
+
+By default, the generated CSV file has 8 columns for each line (it can
+be customized with the @code{COB_PROF_FORMAT} environment/runtime
+configuration):
+
+@table @code
+
+@item program-id
+
+The program identifier of the module.
+
+@item section
+
+The name of the section. The time of a section is not computed
+directly, but as the sum of the time spent in its paragraphs.
+
+@item paragraph
+
+The name of the paragraph. If a section has no paragraph, or does not
+start with a paragraph, a default paragraph called
+@code{MAIN PARAGRAPH} is created.
+
+@item entry
+
+The name of the entry for @code{ENTRY} statements, or the name of the
+target for @code{CALL} statements. No time is associated with
+@code{ENTRY} statements, as the time is directly included in the
+including paragraph. However, the number of calls is still recorded.
+
+@item location
+
+The file and line number of the corresponding entry point (section or
+paragraph)
+
+@item kind
+
+The kind is either @code{PROGRAM}, @code{SECTION}, @code{PARAGRAPH},
+@code{CALL} or @code{ENTRY}.
+
+@item time-ns
+
+The time spent in the module/section/paragraph/call in nanoseconds
+
+@item time
+
+The time spent in the module/section/paragraph/call in a human
+readable form (currently, the time in seconds and milliseconds)
+
+@item ncalls
+
+The number of calls to this section/paragraph
+
+@end table
+
+@node Extensions, System Routines, Profiling, Top
@chapter Non-standard extensions
@cindex Extensions
@cindex Non-standard extensions
diff --git a/libcob/ChangeLog b/libcob/ChangeLog
index fe972dd3b..0734c7536 100644
--- a/libcob/ChangeLog
+++ b/libcob/ChangeLog
@@ -1,3 +1,13 @@
+2023-09-04 Fabrice Le Fessant and Emilien Lemaire
+
+ * Makefile.am: add `profiling.c` to sources
+ * profiling.c: implement profiling functions
+ (time spent in each procedure of the program)
+ * common.c: add 4 environments variables COB_PROF_FILE,
+ COB_PROF_MAX_DEPTH,COB_PROF_ENABLE and COB_PROF_FORMAT
+ * common.c (cob_expand_env_string): add $b (executable basename),
+ $f (executable filename), $d (date in yyyymmdd) and
+ $t (time in hhmmss)
2023-12-14 David Declerck
diff --git a/libcob/Makefile.am b/libcob/Makefile.am
index ce5a4a5cc..3b3747450 100644
--- a/libcob/Makefile.am
+++ b/libcob/Makefile.am
@@ -22,7 +22,7 @@
lib_LTLIBRARIES = libcob.la
libcob_la_SOURCES = common.c move.c numeric.c strings.c \
fileio.c call.c intrinsic.c termio.c screenio.c reportio.c cobgetopt.c \
- mlio.c coblocal.h cconv.c system.def
+ mlio.c coblocal.h cconv.c system.def profiling.c jor.c
if LOCAL_CJSON
nodist_libcob_la_SOURCES = cJSON.c
diff --git a/libcob/coblocal.h b/libcob/coblocal.h
index 27f8de170..f3013c51f 100644
--- a/libcob/coblocal.h
+++ b/libcob/coblocal.h
@@ -347,6 +347,13 @@ typedef struct __cob_settings {
FILE *cob_dump_file; /* FILE* to write DUMP information to */
char *cob_dump_filename; /* Place to write dump of variables */
+ char *cob_jor_filename; /* Place to write the JOR file */
+ int cob_jor_enable; /* Whether JOR is enabled */
+ int cob_jor_max_size; /* Max size of JOR buffer (4096 by default) */
+ char *cob_prof_filename; /* Place to write profiling data */
+ int cob_prof_enable; /* Whether profiling is enabled */
+ int cob_prof_max_depth; /* Max stack depth during profiling (255 by default) */
+ char *cob_prof_format; /* Format of prof CSV line */
int cob_dump_width; /* Max line width for dump */
unsigned int cob_core_on_error; /* signal handling and possible raise of SIGABRT
/ creation of coredumps on runtime errors */
@@ -441,8 +448,10 @@ COB_HIDDEN void cob_init_call (cob_global *, cob_settings *, const int);
COB_HIDDEN void cob_init_intrinsic (cob_global *);
COB_HIDDEN void cob_init_strings (cob_global *);
COB_HIDDEN void cob_init_move (cob_global *, cob_settings *);
+COB_HIDDEN void cob_init_prof (cob_global *, cob_settings *);
COB_HIDDEN void cob_init_screenio (cob_global *, cob_settings *);
COB_HIDDEN void cob_init_mlio (cob_global * const);
+COB_HIDDEN void cob_init_jor (cob_global *, cob_settings *, int, char**);
COB_HIDDEN const char *cob_statement_name[STMT_MAX_ENTRY];
@@ -504,6 +513,9 @@ COB_HIDDEN int cob_field_to_string (const cob_field *, void *,
COB_HIDDEN cob_settings *cob_get_settings_ptr (void);
COB_HIDDEN char *cob_strndup (const char *, const size_t);
+/* Function called by the runtime at the end of execution to save the
+ * profiling information in a file. */
+COB_HIDDEN void cob_prof_end (void);
enum cob_datetime_res {
DTR_DATE,
diff --git a/libcob/common.c b/libcob/common.c
index 9dacd1d94..6a417d64d 100644
--- a/libcob/common.c
+++ b/libcob/common.c
@@ -505,6 +505,13 @@ static struct config_tbl gc_conf[] = {
{"COB_CORE_ON_ERROR", "core_on_error", "0", coeopts, GRP_MISC, ENV_UINT | ENV_ENUMVAL, SETPOS (cob_core_on_error)},
{"COB_CORE_FILENAME", "core_filename", "./core.libcob", NULL, GRP_MISC, ENV_STR, SETPOS (cob_core_filename)},
{"COB_DUMP_FILE", "dump_file", NULL, NULL, GRP_MISC, ENV_FILE, SETPOS (cob_dump_filename)},
+ {"COB_JOR_FILE", "jor_file", "cob-jor-$b-$$-$d-$t.jor", NULL, GRP_MISC, ENV_FILE, SETPOS (cob_jor_filename)},
+ {"COB_JOR_ENABLE", "jor_enable", "0", NULL, GRP_MISC, ENV_BOOL, SETPOS (cob_jor_enable)},
+ {"COB_JOR_MAX_SIZE", "jor_max_size", "8192", NULL, GRP_MISC, ENV_UINT, SETPOS (cob_jor_max_size)},
+ {"COB_PROF_FILE", "prof_file", "cob-prof-$b-$$-$d-$t.csv", NULL, GRP_MISC, ENV_FILE, SETPOS (cob_prof_filename)},
+ {"COB_PROF_ENABLE", "prof_enable", "0", NULL, GRP_MISC, ENV_BOOL, SETPOS (cob_prof_enable)},
+ {"COB_PROF_MAX_DEPTH", "prof_max_depth", "8192", NULL, GRP_MISC, ENV_UINT, SETPOS (cob_prof_max_depth)},
+ {"COB_PROF_FORMAT", "prof_format", "%m,%s,%p,%e,%w,%k,%t,%h,%n", NULL, GRP_MISC, ENV_STR, SETPOS (cob_prof_format)},
{"COB_DUMP_WIDTH", "dump_width", "100", NULL, GRP_MISC, ENV_UINT, SETPOS (cob_dump_width)},
#ifdef _WIN32
/* checked before configuration load if set from environment in cob_common_init() */
@@ -812,6 +819,7 @@ cob_terminate_routines (void)
}
fflush (stderr);
+ cob_prof_end();
cob_exit_fileio_msg_only ();
if (COB_MODULE_PTR && abort_reason[0] != 0) {
@@ -1108,6 +1116,7 @@ cob_sig_handler (int sig)
#ifdef HAVE_SIG_ATOMIC_T
if (sig_is_handled) {
+ cob_jor_exit (sig, "signal %d caused termination (2)", sig);
#ifdef HAVE_RAISE
raise (sig);
#else
@@ -1239,12 +1248,14 @@ cob_sig_handler (int sig)
sig = SIGABRT;
}
signal (sig, SIG_DFL);
+ cob_jor_exit (sig, "signal %d caused termination", sig);
+
#ifdef HAVE_RAISE
raise (sig);
#else
kill (cob_sys_getpid (), sig);
#endif
-
+
#if 0 /* we don't necessarily want the OS to handle this,
so exit in all other cases*/
exit (sig);
@@ -3045,6 +3056,7 @@ cob_stop_run (const int status)
longjmp (return_jmp_buf, 1);
}
#endif
+ cob_jor_exit (status, "STOP RUN reached");
exit (status);
}
@@ -3099,6 +3111,8 @@ cob_hard_failure ()
longjmp (return_jmp_buf, -1);
}
#endif
+ cob_jor_exit (EXIT_FAILURE, "hard failure");
+
/* if explicit requested for errors or
an explicit manual coredump creation did
not work raise an abort here */
@@ -3134,6 +3148,8 @@ cob_hard_failure_internal (const char *prefix)
longjmp (return_jmp_buf, -2);
}
#endif
+ cob_jor_exit (EXIT_FAILURE, "hard failure (%s)", prefix);
+
/* if explicit requested for errors or
an explicit manual coredump creation did
not work raise an abort here */
@@ -7746,17 +7762,53 @@ var_print (const char *msg, const char *val, const char *default_val,
}
+/* Returns an allocated string containing a sub-string of argument
+ * started after the last a /, \ or :, and before the first following
+ * dot. */
+static char *
+get_basename (const char *s)
+{
+ char buf [COB_NORMAL_BUFF];
+ int dot = 0;
+ int pos = 0;
+
+ if (!s) return NULL;
+ while (*s && pos < COB_NORMAL_BUFF-1){
+ switch (*s){
+ case '/':
+ case '\\':
+ case ':':
+ pos = 0;
+ dot = 0;
+ break;
+ case '.':
+ dot = 1;
+ break;
+ default:
+ if (!dot){
+ buf[pos++] = *s;
+ }
+ }
+ s++;
+ }
+ buf[pos] = 0;
+ return cob_strdup (buf);
+}
+
+
/*
Expand a string with environment variable in it.
Return malloced string.
+ Variables should have the format ${var} or ${var:default}.
+ $$ is used for the process ID
*/
char *
-cob_expand_env_string (char *strval)
+cob_expand_env_string (const char *strval)
{
unsigned int i;
unsigned int j = 0;
unsigned int k = 0;
- size_t envlen = 1280;
+ size_t envlen = 1280;
char *env;
char *str;
char ename[128] = { '\0' };
@@ -7817,12 +7869,58 @@ cob_expand_env_string (char *strval)
k++;
}
k--;
- } else if (strval[k] == '$'
- && strval[k+1] == '$') { /* Replace $$ with process-id */
- j += sprintf (&env[j], "%d", cob_sys_getpid());
- k++;
- /* CHECME: possibly add $f /$b as basename of executable [or, when passed to cob_init the first name]
- along with $d date as yyyymmdd and $t as hhmmss */
+ } else if (strval[k] == '$') {
+ struct cob_time time;
+ char *need_free = NULL;
+ const char *s = NULL;
+ switch ( strval[k+1] ){
+ case '$': /* Replace $$ with process-id */
+ j += sprintf (&env[j], "%d", cob_sys_getpid());
+ k++;
+ break;
+ case 'f': /* $f is the executable filename */
+ if (!cobglobptr->cob_main_argv0){
+ env[j++] = strval[k];
+ } else {
+ s = cobglobptr->cob_main_argv0;
+ }
+ break;
+ case 'b': /* $b is the executable basename */
+ if (!cobglobptr->cob_main_argv0){
+ env[j++] = strval[k];
+ } else {
+ need_free = get_basename (cobglobptr->cob_main_argv0);
+ s = need_free;
+ }
+ break;
+ case 'd': /* $d date as yyyymmdd */
+ time = cob_get_current_datetime (DTR_DATE);
+ j += sprintf (&env[j], "%04d%02d%02d",
+ time.year, time.month,
+ time.day_of_month);
+ k++;
+ break;
+ case 't': /* $t time as hhmmss */
+ time = cob_get_current_datetime (DTR_TIME_NO_NANO);
+ j += sprintf (&env[j], "%02d%02d%02d",
+ time.hour, time.minute, time.second);
+ k++;
+ break;
+ default:
+ env[j++] = strval[k];
+ break;
+ }
+ if (s){
+ size_t copylen = strlen(s);
+ if (copylen + j > envlen - 128) {
+ env = cob_realloc (env, envlen,
+ j + copylen + 256);
+ envlen = j + copylen + 256;
+ }
+ j += sprintf (&env[j], "%s", s);
+ k++;
+ if (need_free) cob_free(need_free);
+ }
} else if (!isspace ((unsigned char)strval[k])) {
env[j++] = strval[k];
} else {
@@ -10055,8 +10153,9 @@ cob_call_with_exception_check (const char *name, const int argc, void **argv)
return 0;
}
-void
-cob_init (const int argc, char **argv)
+
+static
+void cob_set_main_argv0 (const int argc, char **argv)
{
char *s;
#if defined (HAVE_READLINK) || defined (HAVE_GETEXECNAME)
@@ -10064,6 +10163,85 @@ cob_init (const int argc, char **argv)
#endif
int i;
+#ifdef _WIN32
+ s = cob_malloc ((size_t)COB_LARGE_BUFF);
+ i = GetModuleFileNameA (NULL, s, COB_LARGE_MAX);
+ if (i > 0 && i < COB_LARGE_BUFF) {
+ cobglobptr->cob_main_argv0 = cob_strdup (s);
+ cob_free (s);
+ return;
+ }
+ cob_free (s);
+#elif defined (HAVE_READLINK)
+ path = NULL;
+ if (!access ("/proc/self/exe", R_OK)) {
+ path = "/proc/self/exe";
+ } else if (!access ("/proc/curproc/file", R_OK)) {
+ path = "/proc/curproc/file";
+ } else if (!access ("/proc/self/path/a.out", R_OK)) {
+ path = "/proc/self/path/a.out";
+ }
+ if (path) {
+ s = cob_malloc ((size_t)COB_LARGE_BUFF);
+ i = (int)readlink (path, s, (size_t)COB_LARGE_MAX);
+ if (i > 0 && i < COB_LARGE_BUFF) {
+ s[i] = 0;
+ cobglobptr->cob_main_argv0 = cob_strdup (s);
+ cob_free (s);
+ return;
+ }
+ cob_free (s);
+ }
+#endif
+
+#ifdef HAVE_GETEXECNAME
+ path = getexecname ();
+ if (path) {
+#ifdef HAVE_REALPATH
+ s = cob_malloc ((size_t)COB_LARGE_BUFF);
+ if (realpath (path, s) != NULL) {
+ cobglobptr->cob_main_argv0 = cob_strdup (s);
+ } else {
+ cobglobptr->cob_main_argv0 = cob_strdup (path);
+ }
+ cob_free (s);
+#else
+ cobglobptr->cob_main_argv0 = cob_strdup (path);
+#endif
+ return;
+ }
+#endif
+
+ if (argc && argv && argv[0]) {
+#if defined (HAVE_CANONICALIZE_FILE_NAME)
+ /* Returns malloced path or NULL */
+ cobglobptr->cob_main_argv0 = canonicalize_file_name (argv[0]);
+#elif defined (HAVE_REALPATH)
+ s = cob_malloc ((size_t)COB_LARGE_BUFF);
+ if (realpath (argv[0], s) != NULL) {
+ cobglobptr->cob_main_argv0 = cob_strdup (s);
+ }
+ cob_free (s);
+#elif defined (_WIN32)
+ /* Returns malloced path or NULL */
+ cobglobptr->cob_main_argv0 = _fullpath (NULL, argv[0], 1);
+#endif
+ if (!cobglobptr->cob_main_argv0) {
+ cobglobptr->cob_main_argv0 = cob_strdup (argv[0]);
+ }
+ } else {
+ cobglobptr->cob_main_argv0 = cob_strdup (_("unknown"));
+ }
+ /* The above must be last in this function as we do early return */
+ /* from certain ifdef's */
+}
+
+void
+cob_init (const int argc, char **argv)
+{
+ char *s;
+ int i;
+
/* Ensure initialization is only done once. Within generated modules and
libcob this is already ensured, but an external caller may call this
function again */
@@ -10113,6 +10291,8 @@ cob_init (const int argc, char **argv)
/* Get global structure */
cobglobptr = cob_malloc (sizeof (cob_global));
+ cob_set_main_argv0 (argc, argv);
+
/* Get settings structure */
cobsetptr = cob_malloc (sizeof (cob_settings));
@@ -10183,11 +10363,13 @@ cob_init (const int argc, char **argv)
/* Call inits with cobsetptr to get the addresses of all */
/* Screen-IO might be needed for error outputs */
+ cob_init_jor (cobglobptr, cobsetptr, cob_argc, cob_argv);
cob_init_screenio (cobglobptr, cobsetptr);
cob_init_cconv (cobglobptr);
cob_init_numeric (cobglobptr);
cob_init_strings (cobglobptr);
cob_init_move (cobglobptr, cobsetptr);
+ cob_init_prof (cobglobptr, cobsetptr);
cob_init_intrinsic (cobglobptr);
cob_init_fileio (cobglobptr, cobsetptr);
cob_init_call (cobglobptr, cobsetptr, check_mainhandle);
@@ -10237,81 +10419,6 @@ cob_init (const int argc, char **argv)
}
#endif
}
-
- /* This must be last in this function as we do early return */
- /* from certain ifdef's */
-
-#ifdef _WIN32
- s = cob_malloc ((size_t)COB_LARGE_BUFF);
- i = GetModuleFileNameA (NULL, s, COB_LARGE_MAX);
- if (i > 0 && i < COB_LARGE_BUFF) {
- cobglobptr->cob_main_argv0 = cob_strdup (s);
- cob_free (s);
- return;
- }
- cob_free (s);
-#elif defined (HAVE_READLINK)
- path = NULL;
- if (!access ("/proc/self/exe", R_OK)) {
- path = "/proc/self/exe";
- } else if (!access ("/proc/curproc/file", R_OK)) {
- path = "/proc/curproc/file";
- } else if (!access ("/proc/self/path/a.out", R_OK)) {
- path = "/proc/self/path/a.out";
- }
- if (path) {
- s = cob_malloc ((size_t)COB_LARGE_BUFF);
- i = (int)readlink (path, s, (size_t)COB_LARGE_MAX);
- if (i > 0 && i < COB_LARGE_BUFF) {
- s[i] = 0;
- cobglobptr->cob_main_argv0 = cob_strdup (s);
- cob_free (s);
- return;
- }
- cob_free (s);
- }
-#endif
-
-#ifdef HAVE_GETEXECNAME
- path = getexecname ();
- if (path) {
-#ifdef HAVE_REALPATH
- s = cob_malloc ((size_t)COB_LARGE_BUFF);
- if (realpath (path, s) != NULL) {
- cobglobptr->cob_main_argv0 = cob_strdup (s);
- } else {
- cobglobptr->cob_main_argv0 = cob_strdup (path);
- }
- cob_free (s);
-#else
- cobglobptr->cob_main_argv0 = cob_strdup (path);
-#endif
- return;
- }
-#endif
-
- if (argc && argv && argv[0]) {
-#if defined (HAVE_CANONICALIZE_FILE_NAME)
- /* Returns malloced path or NULL */
- cobglobptr->cob_main_argv0 = canonicalize_file_name (argv[0]);
-#elif defined (HAVE_REALPATH)
- s = cob_malloc ((size_t)COB_LARGE_BUFF);
- if (realpath (argv[0], s) != NULL) {
- cobglobptr->cob_main_argv0 = cob_strdup (s);
- }
- cob_free (s);
-#elif defined (_WIN32)
- /* Returns malloced path or NULL */
- cobglobptr->cob_main_argv0 = _fullpath (NULL, argv[0], 1);
-#endif
- if (!cobglobptr->cob_main_argv0) {
- cobglobptr->cob_main_argv0 = cob_strdup (argv[0]);
- }
- } else {
- cobglobptr->cob_main_argv0 = cob_strdup (_("unknown"));
- }
- /* The above must be last in this function as we do early return */
- /* from certain ifdef's */
}
/*
diff --git a/libcob/common.h b/libcob/common.h
index e81d175ba..9981fb53b 100644
--- a/libcob/common.h
+++ b/libcob/common.h
@@ -1379,6 +1379,27 @@ typedef struct __cob_file_key {
/* File version (likely can be removed from cob_file in the future) */
#define COB_FILE_VERSION 1
+
+enum cob_jor_file_operation {
+/* order must match field_file_op_name[] in jor.c */
+ COB_JOR_WRITE_TRY = 0,
+ COB_JOR_WRITE_OK,
+ COB_JOR_READ_TRY,
+ COB_JOR_READ_OK,
+ COB_JOR_START_TRY,
+ COB_JOR_START_OK,
+ COB_JOR_OPEN_TRY,
+ COB_JOR_OPEN_OK,
+ COB_JOR_CLOSE_TRY,
+ COB_JOR_CLOSE_OK,
+ COB_JOR_OPERATIONS_MAX
+};
+
+typedef struct __cob_file_jor {
+ int id ;
+ cob_u32_t *ops [COB_JOR_OPERATIONS_MAX] ;
+} cob_file_jor;
+
/* File structure */
/*NOTE: *** Add new fields to end ***
@@ -1435,6 +1456,7 @@ typedef struct __cob_file {
const unsigned char* code_set_read; /* CODE-SET conversion for READs */
size_t nconvert_fields; /* Number of logical fields to convert */
cob_field *convert_field; /* logical fields to convert for CODE-SET */
+ cob_file_jor *jor; /* job occurrence report */
} cob_file;
@@ -1724,7 +1746,7 @@ COB_EXPIMP void cob_set_locale (cob_field *, const int);
COB_EXPIMP int cob_setenv (const char *, const char *, int);
COB_EXPIMP int cob_unsetenv (const char *);
COB_EXPIMP char *cob_getenv_direct (const char *);
-COB_EXPIMP char *cob_expand_env_string (char *);
+COB_EXPIMP char *cob_expand_env_string (const char *);
COB_EXPIMP char *cob_getenv (const char *);
COB_EXPIMP int cob_putenv (char *);
@@ -2864,6 +2886,44 @@ COB_EXPIMP cob_field *cob_intr_bit_to_char (cob_field *);
COB_EXPIMP cob_field* cob_intr_hex_of (cob_field*);
COB_EXPIMP cob_field* cob_intr_hex_to_char (cob_field*);
+
+
+/************************/
+/* Functions in jor.c */
+/************************/
+
+#define JOR_MAGIC "GNUCOJOR"
+#define JOR_MAGIC_LEN 8
+#define JOR_HEADER_SIZE 16
+
+#define OPCODE_NEW_NAME 0
+#define OPCODE_LOCAL_FIELD 1
+
+enum jor_operation_type {
+ TYPE_RECORD = 0,
+ TYPE_UINT8,
+ TYPE_INT8,
+ TYPE_UINT16,
+ TYPE_INT16,
+ TYPE_UINT32,
+ TYPE_INT32,
+ TYPE_UINT64,
+ TYPE_INT64,
+ TYPE_FLOAT,
+ TYPE_STRING8,
+ TYPE_STRING16 /* = 11 */
+};
+
+COB_EXPIMP void cob_jor_exit (int, const char*, ...);
+COB_EXPIMP void cob_jor_file_operation (cob_file*, enum cob_jor_file_operation);
+
+/* For extensions to update the way JOR are allocated and saved/sent. */
+struct cob_jor_funcs {
+ void (*save) (const char* filename, char* buffer, int len);
+ char* (*allocate)(int *size);
+};
+COB_EXPIMP void cob_jor_set_funcs (struct cob_jor_funcs *);
+
/************************/
/* Functions in cconv.c */
/************************/
@@ -2956,4 +3016,64 @@ typedef char * cobchar_t;
/*******************************/
+
+/* Type to store nanoseconds */
+typedef unsigned long long cob_ns_time;
+
+enum cob_prof_procedure_kind {
+ COB_PROF_PROCEDURE_MODULE,
+ COB_PROF_PROCEDURE_SECTION,
+ COB_PROF_PROCEDURE_PARAGRAPH,
+ COB_PROF_PROCEDURE_ENTRY,
+ COB_PROF_PROCEDURE_CALL
+};
+
+struct cob_prof_procedure {
+ /* Name of the module or section or paragraph or entry */
+ const char *text;
+ /* File Location */
+ const char *file;
+ int line;
+ /* Index of the section record of this procedure. In the case
+ of COB_PROF_PROCEDURE_ENTRY, the "section" field is in fact
+ the paragraph, not the section */
+ int section;
+ /* Kind of procedure. */
+ enum cob_prof_procedure_kind kind;
+};
+
+/* Structure storing profiling information about each COBOL module */
+struct cob_prof_module {
+ /* Array of execution times */
+ cob_ns_time *total_times;
+ /* Array of execution counts */
+ unsigned int *called_count;
+ /* Array of current recursions per procedure */
+ unsigned int *procedure_recursions;
+ /* Array of procedure descriptions */
+ struct cob_prof_procedure *procedures ;
+ /* Number of procedures */
+ size_t procedure_count;
+};
+
+/* Function called to start profiling a COBOL module. Allocates the
+ cob_prof_module structure that will be used to store the counters and
+ times. */
+COB_EXPIMP struct cob_prof_module *cob_prof_init_module (
+ cob_module *module,
+ struct cob_prof_procedure *procedure_names,
+ size_t procedure_count);
+
+/* Functions used to instrument the generated C code and measure
+ * counters and times */
+COB_EXPIMP void cob_prof_enter_procedure (struct cob_prof_module *, int);
+COB_EXPIMP void cob_prof_exit_procedure (struct cob_prof_module *, int);
+COB_EXPIMP void cob_prof_enter_section (struct cob_prof_module *, int);
+COB_EXPIMP void cob_prof_exit_section (struct cob_prof_module *, int);
+
+/* Enter a paragraph in the middle, using an ENTRY statement */
+COB_EXPIMP void cob_prof_use_paragraph_entry (struct cob_prof_module *, int, int);
+/* Exit a paragraph using a GO TO */
+COB_EXPIMP void cob_prof_goto (struct cob_prof_module *);
+
#endif /* COB_COMMON_H */
diff --git a/libcob/fileio.c b/libcob/fileio.c
index 4a644e1fe..649dfd2ad 100644
--- a/libcob/fileio.c
+++ b/libcob/fileio.c
@@ -6148,6 +6148,10 @@ cob_open (cob_file *f, const int mode, const int sharing, cob_field *fnstatus)
{
/*: GC4: mode as cob_open_mode */
+ int ret;
+
+ cob_jor_file_operation (f, COB_JOR_OPEN_TRY);
+
last_operation_open = 1;
/* File was previously closed with lock */
@@ -6274,9 +6278,13 @@ cob_open (cob_file *f, const int mode, const int sharing, cob_field *fnstatus)
#endif
/* Open the file */
- save_status (f, fnstatus,
- fileio_funcs[(int)f->organization]->open (f, file_open_name,
- mode, sharing));
+ ret = fileio_funcs[(int)f->organization]->open (f, file_open_name,
+ mode, sharing);
+
+ if ( ret == COB_STATUS_00_SUCCESS )
+ cob_jor_file_operation (f, COB_JOR_OPEN_OK);
+
+ save_status (f, fnstatus, ret);
}
void
@@ -6286,6 +6294,8 @@ cob_close (cob_file *f, cob_field *fnstatus, const int opt, const int remfil)
struct file_list *m;
int ret;
+ cob_jor_file_operation (f, COB_JOR_CLOSE_TRY);
+
f->flag_read_done = 0;
f->flag_operation = 0;
@@ -6331,6 +6341,7 @@ cob_close (cob_file *f, cob_field *fnstatus, const int opt, const int remfil)
ret = fileio_funcs[(int)f->organization]->close (f, opt);
if (ret == COB_STATUS_00_SUCCESS) {
+ cob_jor_file_operation (f, COB_JOR_CLOSE_OK);
switch (opt) {
case COB_CLOSE_LOCK:
f->open_mode = COB_OPEN_LOCKED;
@@ -6374,6 +6385,8 @@ cob_start (cob_file *f, const int cond, cob_field *key,
int ret;
cob_field tempkey;
+ cob_jor_file_operation (f, COB_JOR_START_TRY);
+
f->flag_read_done = 0;
f->flag_first_read = 0;
@@ -6406,6 +6419,8 @@ cob_start (cob_file *f, const int cond, cob_field *key,
ret = fileio_funcs[(int)f->organization]->start (f, cond, key);
}
if (ret == COB_STATUS_00_SUCCESS) {
+ cob_jor_file_operation (f, COB_JOR_START_OK);
+
f->flag_end_of_file = 0;
f->flag_begin_of_file = 0;
f->flag_first_read = 1;
@@ -6423,6 +6438,8 @@ cob_read (cob_file *f, cob_field *key, cob_field *fnstatus, const int read_opts)
{
int ret;
+ cob_jor_file_operation (f, COB_JOR_READ_TRY);
+
f->flag_read_done = 0;
if (unlikely (f->open_mode != COB_OPEN_INPUT
@@ -6467,6 +6484,8 @@ cob_read (cob_file *f, cob_field *key, cob_field *fnstatus, const int read_opts)
#if defined (COB_EXPERIMENTAL)
case COB_STATUS_0P_NOT_PRINTABLE:
#endif
+ cob_jor_file_operation (f, COB_JOR_READ_OK);
+
f->flag_first_read = 0;
f->flag_read_done = 1;
f->flag_end_of_file = 0;
@@ -6635,6 +6654,10 @@ void
cob_write (cob_file *f, cob_field *rec, const int opt, cob_field *fnstatus,
const unsigned int check_eop)
{
+ int status;
+
+ cob_jor_file_operation (f, COB_JOR_WRITE_TRY);
+
f->flag_read_done = 0;
if (f->access_mode == COB_ACCESS_SEQUENTIAL) {
@@ -6726,15 +6749,20 @@ cob_write (cob_file *f, cob_field *rec, const int opt, cob_field *fnstatus,
return;
}
f->record->data = converted_copy;
- save_status (f, fnstatus,
- fileio_funcs[(int)f->organization]->write (f, opt));
+ status = fileio_funcs[(int)f->organization]->write (f, opt);
+ if (status == COB_STATUS_00_SUCCESS)
+ cob_jor_file_operation (f, COB_JOR_WRITE_OK);
+ save_status (f, fnstatus, status);
+
f->record->data = real_rec_data;
cob_free (converted_copy);
return;
}
- save_status (f, fnstatus,
- fileio_funcs[(int)f->organization]->write (f, opt));
+ status = fileio_funcs[(int)f->organization]->write (f, opt);
+ if (status == COB_STATUS_00_SUCCESS)
+ cob_jor_file_operation (f, COB_JOR_WRITE_OK);
+ save_status (f, fnstatus, status);
}
void
diff --git a/libcob/jor.c b/libcob/jor.c
new file mode 100644
index 000000000..48e06c4d3
--- /dev/null
+++ b/libcob/jor.c
@@ -0,0 +1,497 @@
+/*
+ Copyright (C) 2024 Free Software Foundation, Inc.
+ Written by Fabrice LE FESSANT.
+
+ This file is part of GnuCOBOL.
+
+ The GnuCOBOL compiler is free software: you can redistribute it
+ and/or modify it under the terms of the GNU General Public License
+ as published by the Free Software Foundation, either version 3 of the
+ License, or (at your option) any later version.
+
+ GnuCOBOL is distributed in the hope that it will be useful,
+ but WITHOUT 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
+ along with GnuCOBOL. If not, see .
+*/
+
+#include
+#include
+#include
+#include
+#include
+#include
+
+#include "config.h"
+
+/* include internal and external libcob definitions, forcing exports */
+#define COB_LIB_EXPIMP
+#include "coblocal.h"
+
+#include "tarstamp.h"
+#include "common.h"
+
+#include
+#ifdef HAVE_UNISTD_H
+#include
+#endif
+
+#ifdef _WIN32
+#define WIN32_LEAN_AND_MEAN
+#include
+#undef MOUSE_MOVED
+#include
+#include
+#include /* for _O_BINARY only */
+#endif
+
+#include
+#include
+
+/* Remember static and dynamic configuration */
+static cob_global *cobglobptr = NULL;
+static cob_settings *cobsetptr = NULL;
+static const char* cob_jor_filename ;
+
+static int is_active = 0;
+static char* jor_buffer ;
+static int jor_size ;
+static char* jor_position ;
+static int jor_name_counter ;
+
+static struct timeval tv0;
+static int file_counter = 0;
+
+static int field_secs ;
+static int field_usecs ;
+static int field_status ;
+static int field_reason ;
+static int field_file ;
+static int field_name ;
+static int field_truncated ;
+static int field_start ;
+static int field_exit ;
+static int field_duration ;
+static int field_time ;
+static int field_args ;
+static int field_filename ;
+
+static int field_file_op[COB_JOR_OPERATIONS_MAX] ;
+
+static const char* field_file_op_name[COB_JOR_OPERATIONS_MAX] = {
+ "write-try",
+ "write-ok",
+ "read-try",
+ "read-ok",
+ "start-try",
+ "start-ok",
+ "open-try",
+ "open-ok",
+ "close-try",
+ "close-ok",
+};
+
+#define JOR_MIN_END_SIZE 256
+#define JOR_VERSION 1
+
+/* JOR format:
+
+ * the idea is to have it binary (for size) and extensible (a tool
+ should be able to read both new and old versions without problem)
+
+ HEADER: 16 bytes
+ * u8[8]: magic = GNUCOJOR"
+ * u32: total size of JOR (including the HEADER)
+ * u8: version (currently 1)
+ * u8: byte order (little-endian = 0, big-endian = 1)
+ * u8[2]: padding (not used)
+
+ JOURNAL: a concatenation of records
+
+ * RECORD:
+ * u16: size of record (including this size)
+ * u8: opcode
+ * PAYLOAD: depends on opcode
+
+ * OPCODES:
+ * 0 = NEW FIELD NAME: defines the identifier associated with a new field
+ names. Identifiers should be consecutive in 0.255
+ payload:
+ * u8: identifier
+ * u8: size of field name = LEN
+ * u8[LEN]: field name
+
+ * 1 = LOCAL FIELD: defines a new field, or rewrite an existing field. The
+ field as an identifier (the name of the field), a level (level 0
+ is a toplevel value, level N>0 is a field inside the latest record
+ at level N-1) and a value.
+ payload:
+ * u8: level
+ * u8: field identifier
+ * u8: type identifier TYPE
+ * u8[sizeof(TYPE)]: value of type TYPE
+
+ * TYPES:
+ * 0 = record (fields are added in new records)
+ size: 0
+ * 1 = uint8
+ * u8: value
+ * 2 = int8
+ * i8: value
+ * 3 = uint16
+ * u16: value
+ * 4 = int16
+ * i16: value
+ * 5 = uint32
+ * u32: value
+ * 6 = int32
+ * i32: value
+ * 7 = uint64
+ * u64: value
+ * 8 = int64
+ * i64: value
+ * 9 = double
+ * u64: IEEE float
+ * 10 = string8 (string of size < 256)
+ * u8: LEN of string (without ending 0)
+ * u8[LEN] : string
+ * 11 = string16 (string of size > 255)
+ * u16: LEN of string (without ending 0)
+ * u8[LEN] : string
+
+A typical JOR extracted in textual form will look like:
+
+start = {
+ time = {
+ secs = UnixTime (secs)
+ usecs = UnixTime (remaining usecs)
+ }
+ args = {
+ name = "cobcrun"
+ name = "MXAUTV78"
+ }
+}
+
+file = {
+ name = "FILE"
+ open-try = 1
+ open-ok = 1
+ read-try = 10
+ read-ok = 9
+ close-try = 1
+ close-ok = 1
+}
+
+exit = {
+ status = 0
+ reason = "STOP RUN"
+ time = {
+ secs = ...
+ usecs = ...
+ }
+ duration = {
+ secs = ...
+ usecs = ...
+ }
+}
+
+ */
+
+#define SET_U16(addr, v) \
+ *((cob_u16_t*) (addr)) = v
+
+#define SET_U32(addr, v) \
+ *((cob_u32_t*) (addr)) = v
+
+
+#define RECORD_BEGIN(opcode) { \
+ char *jor_record_begin = jor_position; \
+ jor_position += 2; \
+ *jor_position++ = opcode
+#define RECORD_END() \
+ SET_U16( jor_record_begin, \
+ jor_position - jor_record_begin); \
+ SET_U32( jor_buffer+JOR_MAGIC_LEN, \
+ jor_position - jor_buffer); \
+ }
+#define RECORD_FIELD(level,field,type) \
+ *jor_position++ = level; \
+ *jor_position++ = field; \
+ *jor_position++ = type
+
+static int jor_field_name (const char* s)
+{
+ int id = jor_name_counter++;
+ int len = strlen (s);
+ RECORD_BEGIN (OPCODE_NEW_NAME);
+ *jor_position++ = id;
+ *jor_position++ = len;
+ memcpy (jor_position, s, len);
+ jor_position += len;
+ RECORD_END ();
+ return id;
+}
+
+static void jor_field_record (int level, int field)
+{
+ RECORD_BEGIN (OPCODE_LOCAL_FIELD);
+ RECORD_FIELD (level, field, TYPE_RECORD);
+ RECORD_END ();
+}
+
+static void jor_field_uint8 (int level, int field, cob_u8_t v)
+{
+ RECORD_BEGIN (OPCODE_LOCAL_FIELD);
+ RECORD_FIELD (level, field, TYPE_UINT8);
+ *jor_position++ = v;
+ RECORD_END ();
+}
+static void jor_field_uint32 (int level, int field, cob_u32_t v)
+{
+ RECORD_BEGIN (OPCODE_LOCAL_FIELD);
+ RECORD_FIELD (level, field, TYPE_UINT32);
+ SET_U32 (jor_position, v);
+ jor_position += 4;
+ RECORD_END ();
+}
+static void jor_field_string8 (int level, int field, const char* v)
+{
+ int len = v != NULL ? strlen(v) : 0;
+ RECORD_BEGIN (OPCODE_LOCAL_FIELD);
+ RECORD_FIELD (level, field, TYPE_STRING8);
+ *jor_position++ = len;
+ if (len>0){
+ memcpy ( jor_position, v, len);
+ jor_position += len;
+ }
+ RECORD_END ();
+}
+
+static
+char* jor_allocate(int *size)
+{
+ return cob_malloc(*size);
+}
+
+static
+void jor_save (const char* filename, char* buffer, int len)
+{
+ FILE *fd = fopen (filename, "w");
+ const char* s = jor_buffer;
+ fwrite (s, 1, len, fd);
+ fclose (fd);
+}
+
+static struct cob_jor_funcs jor_funcs = {
+ jor_save,
+ jor_allocate
+};
+
+/*
+\brief Function used to overwrite the default functions used to
+ allocate the memory buffer for the JOR file, and later, to save
+ the memory buffer to disk.
+\param f The new functions to use.
+ */
+void cob_jor_set_funcs (struct cob_jor_funcs *f)
+{
+ if (f->save) jor_funcs.save = f->save;
+ if (f->allocate) jor_funcs.allocate = f->allocate;
+}
+
+
+/*
+\brief Function called during the initialisation of the execution. The space
+ for the JOR file is allocated in memory and the first records are written
+ in the space (but nothing on disk).
+\param lptr Global settings
+\param sptr Runtime configuration
+\param argc Number of arguments with which the program was called
+\param argv The arguments themselves
+*/
+void cob_init_jor (cob_global *lptr, cob_settings *sptr,
+ int argc, char** argv)
+{
+ int i;
+
+ cobglobptr = lptr;
+ cobsetptr = sptr;
+ cob_jor_filename = cob_strdup (cobsetptr->cob_jor_filename);
+
+ /* Check that these fields have been correctly initialized
+ by the developer. */
+ if ( field_file_op_name[COB_JOR_OPERATIONS_MAX-1] == NULL ){
+ fprintf (stderr,
+ "field_file_op_name[%d] not initialized\n",
+ COB_JOR_OPERATIONS_MAX-1);
+ exit (2);
+ }
+
+ if (!cobsetptr->cob_jor_enable &&
+ /* testsuite clears COB_JOR_ENABLE... */
+ !getenv ("COB_JOR_ENABLED")) return ;
+
+ if (argc == 0) return ;
+
+ is_active = 1;
+
+ /* Initialize JOR buffer */
+ jor_buffer = jor_funcs.allocate
+ (& cobsetptr->cob_jor_max_size);
+
+ jor_size = cobsetptr->cob_jor_max_size ;
+ jor_position = jor_buffer;
+
+ memcpy (jor_buffer, JOR_MAGIC, JOR_MAGIC_LEN);
+ jor_position +=JOR_MAGIC_LEN+4; /* magic + size of journal */
+ *jor_position++ = JOR_VERSION; /* version */
+#ifdef WORDS_BIGENDIAN
+ *jor_position = 1; /* byte-order = BIG ENDIAN */
+#else
+ *jor_position = 0; /* byte-order = LITTLE ENDIAN */
+#endif
+ jor_position++;
+ jor_position += 2; /* padding */
+
+ /* Initialize JOR field names */
+ field_start = jor_field_name ("start");
+ field_exit = jor_field_name ("exit");
+ field_duration = jor_field_name ("duration");
+ field_secs = jor_field_name ("secs");
+ field_usecs = jor_field_name ("usecs");
+ field_status = jor_field_name ("status");
+ field_reason = jor_field_name ("reason");
+ field_file = jor_field_name ("file");
+ field_name = jor_field_name ("name");
+ field_time = jor_field_name ("time");
+ field_args = jor_field_name ("args");
+ field_filename = jor_field_name ("filename");
+
+ /* Start storing information */
+ gettimeofday (&tv0, NULL);
+ jor_field_record (0, field_start);
+ jor_field_record (1, field_time);
+ jor_field_uint32 (2, field_secs, tv0.tv_sec);
+ jor_field_uint32 (2, field_usecs, tv0.tv_usec);
+ jor_field_record (1, field_args);
+ for (i=0; i jor_size - JOR_MIN_END_SIZE){
+ truncated = 1;
+ field_truncated = jor_field_name ("truncated");
+ jor_field_uint8 (0, field_truncated, 1);
+ return 1;
+ }
+
+ return 0;
+}
+
+/*
+\brief Function called when an operation has been executed on a file, to
+ increase the corresponding counter in the JOR file
+\param f The structure describing the file
+\param op The operation that has been executed
+*/
+void cob_jor_file_operation (cob_file *f, enum cob_jor_file_operation op)
+{
+ if (is_active){
+ cob_u32_t *counter ;
+
+ if (!f->jor){
+ if (jor_truncate()) return;
+ f->jor = cob_malloc (sizeof(cob_file_jor));
+ f->jor->id = file_counter++;
+ jor_field_record (0, field_file);
+ jor_field_uint8 (1, field_file, f->jor->id);
+ jor_field_string8 (1, field_name,
+ f->select_name);
+ jor_field_string8 (1, field_filename, f->org_filename);
+ }
+
+ counter = f->jor->ops[op];
+
+ if (counter == NULL){
+ int field = field_file_op[op];
+
+ if (jor_truncate()) return;
+
+ if( field == 0 ){
+ field = jor_field_name (field_file_op_name[op]);
+ field_file_op[op] = field;
+ }
+
+ jor_field_record (0, field_file);
+ jor_field_uint8 (1, field_file, f->jor->id);
+ jor_field_uint32 (1, field, 0);
+ counter = (cob_u32_t*) (jor_position-4);
+ f->jor->ops[op] = counter ;
+ }
+ /* counting is "just" allocating the counter in place */
+ (*counter)++;
+ }
+}
+
+/*
+\brief Should be called when the execution terminates, to create the
+ last records of the JOR file and save it to a file.
+\param code The exit code of the program
+\param fmt A message explaining the reason for the termination
+*/
+void cob_jor_exit(int code, const char* fmt, ...)
+{
+ if (is_active){
+ va_list args ;
+ static char exit_reason[COB_MINI_BUFF] = { 0 };
+ struct timeval tv;
+ int len;
+
+ gettimeofday (&tv, NULL);
+
+ va_start (args, fmt);
+ vsnprintf (exit_reason, COB_MINI_BUFF, fmt, args);
+ va_end (args);
+
+ jor_field_record (0, field_exit);
+ jor_field_uint8 (1, field_status, code);
+ jor_field_string8 (1, field_reason, exit_reason);
+
+ jor_field_record (1, field_time);
+ jor_field_uint32 (2, field_secs, tv.tv_sec);
+ jor_field_uint32 (2, field_usecs, tv.tv_usec);
+
+ if ( tv.tv_usec < tv0.tv_usec ){
+ tv.tv_usec += 1000000;
+ tv.tv_sec--;
+ }
+ tv.tv_usec -= tv0.tv_usec;
+ tv.tv_sec -= tv0.tv_sec;
+
+ jor_field_record (1, field_duration);
+ jor_field_uint32 (2, field_secs, tv.tv_sec);
+ jor_field_uint32 (2, field_usecs, tv.tv_usec);
+
+ len = jor_position - jor_buffer;
+ jor_funcs.save (cob_jor_filename, jor_buffer, len);
+ }
+}
+
+
diff --git a/libcob/profiling.c b/libcob/profiling.c
new file mode 100644
index 000000000..b8f10a3a7
--- /dev/null
+++ b/libcob/profiling.c
@@ -0,0 +1,533 @@
+/*
+ Copyright (C) 2023 Free Software Foundation, Inc.
+ Written by Emilien Lemaire and Fabrice Le Fessant.
+
+ This file is part of GnuCOBOL.
+
+ The GnuCOBOL compiler is free software: you can redistribute it
+ and/or modify it under the terms of the GNU General Public License
+ as published by the Free Software Foundation, either version 3 of the
+ License, or (at your option) any later version.
+
+ GnuCOBOL is distributed in the hope that it will be useful,
+ but WITHOUT 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
+ along with GnuCOBOL. If not, see .
+*/
+
+#include
+#include
+#include
+#include
+#include
+
+#include "config.h"
+
+/* include internal and external libcob definitions, forcing exports */
+#define COB_LIB_EXPIMP
+#include "coblocal.h"
+
+#include "tarstamp.h"
+#include "common.h"
+
+#include
+#ifdef HAVE_UNISTD_H
+#include
+#endif
+
+#ifdef _WIN32
+#define WIN32_LEAN_AND_MEAN
+#include
+#undef MOUSE_MOVED
+#include
+#include
+#include /* for _O_BINARY only */
+#endif
+
+/* Local types and variables */
+
+struct cob_prof_module_list {
+ struct cob_prof_module *info ;
+ struct cob_prof_module_list *next;
+};
+
+static struct cob_prof_module_list *prof_info_list ;
+
+/* We maintain a stack of the procedures entered as 3 different
+ * arrays, with "current_idx" being the stack pointer. */
+static cob_ns_time *start_times;
+static int *called_procedures;
+static struct cob_prof_module* *called_runtimes;
+/* Current size of previous arrays */
+static int max_prof_depth;
+static int current_idx = -1;
+
+/* Whether profiling is active or not. */
+static int is_active = 0;
+/* Whether we are in testsuite mode */
+static int is_test = 0;
+
+/* Remember static and dynamic configuration */
+static cob_global *cobglobptr = NULL;
+static cob_settings *cobsetptr = NULL;
+
+
+
+/* Return the current time in nanoseconds. The result is guarranteed
+ * to be monotonic, by using an internal storage of the previous
+ * time. */
+static cob_ns_time
+get_ns_time (void)
+{
+ static cob_ns_time ns_time = 0;
+ if (is_test){
+ ns_time += 1000000;
+ return ns_time;
+ } else {
+ unsigned long long nanoseconds;
+#ifdef _WIN32
+ LARGE_INTEGER performance_counter;
+ LARGE_INTEGER performance_frequency;
+ QueryPerformanceCounter(&performance_counter);
+ QueryPerformanceFrequency(&performance_frequency);
+ performance_counter.QuadPart *= 1000000000;
+ performance_counter.QuadPart /= performance_frequency.QuadPart;
+ nanoseconds = performance_counter.QuadPart;
+ if (nanoseconds>ns_time) ns_time = nanoseconds;
+ return ns_time;
+#else
+#if defined (HAVE_CLOCK_GETTIME)
+ struct timespec ts;
+ clock_gettime(CLOCK_MONOTONIC, &ts);
+ nanoseconds = ts.tv_sec * 1000000000 + ts.tv_nsec;
+#else
+ nanoseconds = clock() * 1000000000 / CLOCKS_PER_SEC;
+#endif /* HAVE_CLOCK_GETTIME */
+#endif /* _WIN32 */
+ if (nanoseconds>ns_time) ns_time = nanoseconds;
+ return ns_time;
+ }
+}
+
+static void
+prof_init_static ()
+{
+ static int init_done = 0;
+
+ if (!init_done && cobsetptr){
+ init_done = 1;
+ is_active = cobsetptr->cob_prof_enable;
+ if (is_active){
+ is_test = !!getenv ("COB_IS_RUNNING_IN_TESTMODE");
+ }
+ }
+}
+
+void cob_init_prof (cob_global *lptr, cob_settings *sptr)
+{
+ cobglobptr = lptr;
+ cobsetptr = sptr;
+}
+
+struct cob_prof_module *
+cob_prof_init_module (cob_module *module,
+ struct cob_prof_procedure *procedures,
+ size_t procedure_count)
+{
+ prof_init_static();
+ if (is_active){
+ struct cob_prof_module *info;
+ struct cob_prof_module_list *item;
+
+ info = cob_malloc (sizeof(struct cob_prof_module));
+ info->total_times = cob_malloc ( procedure_count * sizeof(cob_ns_time) );
+ info->called_count = cob_malloc ( procedure_count * sizeof(unsigned int) );
+ info->procedure_recursions = cob_malloc ( procedure_count * sizeof(unsigned int) );
+ info->procedures = procedures;
+ info->procedure_count = procedure_count;
+
+ item = cob_malloc (sizeof(struct cob_prof_module_list));
+ item->info = info;
+ item->next = prof_info_list;
+ prof_info_list = item;
+ return info;
+ }
+ return NULL;
+}
+
+static void
+cob_prof_realloc_arrays (void)
+{
+ int new_size = max_prof_depth * 2 + 16;
+
+ if (new_size > cobsetptr->cob_prof_max_depth)
+ new_size = cobsetptr->cob_prof_max_depth;
+
+ if (max_prof_depth >= new_size){
+ int i;
+ fprintf (stderr, _("[cob_prof] Profiling overflow at %d calls, aborting profiling.\n"), current_idx);
+ fprintf (stderr, _(" Last 10 calls on stack:\n"));
+ for (i=0;i<10;i++){
+ struct cob_prof_module *info = called_runtimes[current_idx-1-i];
+ int proc_idx = called_procedures[current_idx-1-i];
+ struct cob_prof_procedure *proc = info->procedures + proc_idx;
+ fprintf (stderr, _(" * %s at %s:%d\n"), proc->text,
+ proc->file, proc->line);
+ }
+ is_active = 0;
+ return;
+ }
+
+ if (max_prof_depth){
+ start_times = cob_realloc (
+ start_times,
+ max_prof_depth * sizeof(cob_ns_time),
+ new_size * sizeof(cob_ns_time)
+ );
+ called_procedures = cob_realloc (
+ called_procedures,
+ max_prof_depth * sizeof(int),
+ new_size * sizeof(int)
+ );
+ called_runtimes = cob_realloc (
+ called_runtimes,
+ max_prof_depth * sizeof(struct cob_prof_module*),
+ new_size * sizeof(struct cob_prof_module*)
+ );
+
+ } else {
+ start_times = cob_malloc (new_size * sizeof(cob_ns_time));
+ called_procedures = cob_malloc (new_size * sizeof(int));
+ called_runtimes = cob_malloc (new_size * sizeof(struct cob_prof_module*));
+ }
+ max_prof_depth = new_size;
+}
+
+void
+cob_prof_enter_procedure (struct cob_prof_module *info, int proc_idx)
+{
+ cob_ns_time t;
+
+ if (!is_active) return;
+
+ t = get_ns_time ();
+
+ current_idx++;
+ if (current_idx >= max_prof_depth) {
+ cob_prof_realloc_arrays();
+ if (!is_active) return;
+ }
+
+ called_procedures[current_idx] = proc_idx;
+ called_runtimes[current_idx] = info;
+ start_times[current_idx] = t;
+
+ info->procedure_recursions[proc_idx] ++;
+ info->called_count[proc_idx] ++;
+}
+
+void
+cob_prof_exit_procedure (struct cob_prof_module *info, int proc_idx)
+{
+ /* Exit all the sections/paragraphs */
+ cob_ns_time t;
+
+ if (!is_active) return;
+
+ t = get_ns_time ();
+
+ while (current_idx >= 0) {
+ int curr_proc = called_procedures[current_idx];
+ struct cob_prof_module *curr_info = called_runtimes[current_idx];
+
+ curr_info->procedure_recursions[curr_proc]--;
+ if (curr_info->procedure_recursions[curr_proc]==0){
+ curr_info->total_times[curr_proc] += t - start_times[current_idx];
+ }
+ current_idx--;
+ if (curr_proc == proc_idx && curr_info == info) {
+ return;
+ }
+ }
+}
+
+void
+cob_prof_enter_section (struct cob_prof_module *info, int proc_idx)
+{
+ if (!is_active) return;
+ /* We do not measure time on section enter/exit, we use the cumulative time
+ of all paragraphs of the section */
+ info->called_count[proc_idx] ++;
+}
+
+void
+cob_prof_use_paragraph_entry (struct cob_prof_module *info,
+ int paragraph_idx, int entry_idx){
+ if (!is_active) return;
+ info->called_count[entry_idx] ++;
+ cob_prof_enter_procedure (info, paragraph_idx);
+}
+
+void
+cob_prof_exit_section (struct cob_prof_module *info, int proc_idx)
+{
+ /* For now, nothing to do */
+}
+
+void
+cob_prof_goto (struct cob_prof_module *info)
+{
+ int curr_proc;
+ struct cob_prof_module *curr_info;
+
+ if (!is_active) return;
+
+ curr_proc = called_procedures[current_idx];
+ curr_info = called_runtimes[current_idx];
+
+ if (curr_info->procedures[curr_proc].kind == COB_PROF_PROCEDURE_PARAGRAPH){
+ cob_prof_exit_procedure (curr_info, curr_proc);
+ }
+}
+
+static void
+print_monotonic_time (FILE *file, cob_ns_time t) {
+
+ cob_ns_time nanoseconds = t ;
+ cob_ns_time milliseconds = nanoseconds / 1000000;
+ unsigned int seconds = milliseconds / 1000;
+ milliseconds = milliseconds - 1000 * seconds;
+
+ if (seconds > 1000) {
+ fprintf (file, "%d s", seconds);
+ } else {
+ fprintf (file, "%d.%03Ld s", seconds, milliseconds);
+ }
+}
+
+/* Default format is: "%m,%s,%p,%e,%w,%k,%t,%h,%n" (in common.c) */
+static void
+cob_prof_print_line (
+ FILE *file,
+ struct cob_prof_module *info,
+ int proc_idx)
+{
+ int i;
+ const char *module;
+ const char *section;
+ const char *paragraph;
+ const char *entry;
+ const char *kind;
+ const char *source_file;
+ int line;
+ int ncalls;
+ cob_ns_time time;
+ struct cob_prof_procedure *proc;
+
+ if (info){
+ time = info->total_times[proc_idx];
+ ncalls = info->called_count[proc_idx];
+ proc = info->procedures + proc_idx;
+
+ source_file = proc->file;
+ line = proc->line;
+ switch (proc->kind){
+
+ case COB_PROF_PROCEDURE_MODULE:
+ module = proc->text;
+ section = "";
+ paragraph = "";
+ entry = "";
+ kind = "PROGRAM";
+ break;
+
+ case COB_PROF_PROCEDURE_SECTION:
+ module = info->procedures[0].text;
+ section = proc->text;
+ paragraph = "";
+ entry = "";
+ kind = "SECTION";
+ break;
+
+ case COB_PROF_PROCEDURE_PARAGRAPH:
+ module = info->procedures[0].text;
+ section = info->procedures[proc->section].text;
+ paragraph = proc->text;
+ entry = "";
+ kind = "PARAGRAPH";
+ break;
+
+ case COB_PROF_PROCEDURE_ENTRY:
+ module = info->procedures[0].text;
+ section = info->procedures[
+ info->procedures[proc->section].section].text;
+ paragraph = info->procedures[proc->section].text;
+ entry = proc->text;
+ kind = "ENTRY";
+ break;
+ case COB_PROF_PROCEDURE_CALL:
+ module = info->procedures[0].text;
+ section = info->procedures[
+ info->procedures[proc->section].section].text;
+ paragraph = info->procedures[proc->section].text;
+ entry = proc->text;
+ kind = "CALL";
+ break;
+ }
+ } else {
+ module = "program-id";
+ section = "section";
+ paragraph = "paragraph";
+ entry = "entry";
+ kind = "kind";
+ source_file = "file";
+ ncalls = 0;
+ }
+
+ for (i = 0; cobsetptr->cob_prof_format[i] != 0; i++) {
+ if (cobsetptr->cob_prof_format[i] == '%') {
+ i++;
+ switch (cobsetptr->cob_prof_format[i]) {
+ case 'M':
+ case 'm':
+ fputs (module, file);
+ break;
+ case 'S':
+ case 's':
+ fputs (section, file);
+ break;
+ case 'P':
+ case 'p':
+ fputs (paragraph, file);
+ break;
+ case 'E':
+ case 'e':
+ fputs (entry, file);
+ break;
+ case 'F':
+ case 'f':
+ fputs (source_file, file);
+ break;
+ case 'L':
+ case 'l':
+ if (info){
+ fprintf (file, "%d", line);
+ } else {
+ fputs ("line", file);
+ }
+ break;
+ case 'I':
+ case 'i':
+ if (info){
+ fprintf (file, "%d", cob_sys_getpid());
+ } else {
+ fputs ("pid", file);
+ }
+ break;
+ case 'W':
+ case 'w':
+ if (info){
+ fprintf (file, "%s:%d", source_file, line);
+ } else {
+ fputs ("location", file);
+ }
+ break;
+ case 'K':
+ case 'k':
+ fputs (kind, file);
+ break;
+ case 'T':
+ case 't':
+ if (info){
+ fprintf (file, "%lld", time);
+ } else {
+ fputs ("time-ns", file);
+ }
+ break;
+ case 'H':
+ case 'h':
+ if (info){
+ print_monotonic_time (file, time);
+ } else {
+ fputs ("time", file);
+ }
+ break;
+ case 'N':
+ case 'n':
+ if (info){
+ fprintf (file, "%d", ncalls);
+ } else {
+ fputs ("ncalls", file);
+ }
+ break;
+ default:
+ fputc ('%', file);
+ fputc (cobsetptr->cob_prof_format[i], file);
+ }
+ } else {
+ fputc (cobsetptr->cob_prof_format[i], file);
+ }
+ }
+ fputc ('\n', file);
+ fflush (file);
+}
+
+
+void
+cob_prof_end ()
+{
+ FILE *file;
+ const char* prof_filename = NULL;
+ struct cob_prof_module_list *l;
+
+ prof_init_static ();
+
+ if (!cobsetptr || !is_active || !prof_info_list) return;
+
+ while (current_idx >= 0) {
+ cob_prof_exit_procedure (called_runtimes[current_idx],
+ called_procedures[current_idx]);
+ }
+
+ prof_filename = cobsetptr->cob_prof_filename;
+
+ file = fopen (prof_filename, !cobsetptr->cob_unix_lf ? "w" : "wb");
+
+ if (!!file) {
+
+ /* First pass: accumulate section times */
+ for (l = prof_info_list ; l != NULL; l=l->next){
+
+ struct cob_prof_module *info = l->info;
+ int i;
+
+ for (i = 0; i < info->procedure_count; i++) {
+ if (info->procedures[i].kind == COB_PROF_PROCEDURE_PARAGRAPH){
+ info->total_times[info->procedures[i].section]
+ += info->total_times[i];
+ }
+ }
+ }
+
+ cob_prof_print_line (file, NULL, 0);
+ for (l = prof_info_list ; l != NULL; l=l->next){
+
+ struct cob_prof_module *info = l->info;
+ int i;
+
+ for (i = 0; i < info->procedure_count; i++) {
+ cob_prof_print_line (file, info, i);
+ }
+ }
+ fclose (file);
+ fprintf(stderr, "File %s generated\n", prof_filename);
+ } else {
+ cob_runtime_warning (_("error '%s' opening COB_PROF_FILE '%s'"),
+ cob_get_strerror (), prof_filename);
+ }
+ current_idx = -1;
+ is_active = 0;
+}
diff --git a/tests/ChangeLog b/tests/ChangeLog
index aa1608f63..b8266d4a0 100644
--- a/tests/ChangeLog
+++ b/tests/ChangeLog
@@ -1,3 +1,7 @@
+2023-09-07 Emilien Lemaire
+
+ * testsuite.src/used_binaries.at: add testing for profiling
+
2023-07-10 Simon Sobisch
diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at
index 8a11f5128..be7c6eca8 100644
--- a/tests/testsuite.src/syn_misc.at
+++ b/tests/testsuite.src/syn_misc.at
@@ -8348,3 +8348,258 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [1])
AT_CLEANUP
+
+AT_SETUP([Check recursive calls])
+AT_KEYWORDS([RECURSIVE])
+
+# Some of these tests are expected to fail, either at compile time or run
+# time, but they don't because gnucobol does not perform the checks... yet
+
+AT_DATA([prog1.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog1 RECURSIVE.
+ PROCEDURE DIVISION.
+ DISPLAY "main".
+ CALL "entry".
+ DISPLAY "end-main".
+ GOBACK.
+ ENTRY "entry".
+ DISPLAY "entry".
+])
+
+AT_CHECK([$COMPILE -x prog1.cob])
+
+AT_CHECK([./prog1], [0], [main
+entry
+end-main
+])
+
+AT_DATA([prog2.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog2.
+ PROCEDURE DIVISION.
+ DISPLAY "main".
+ CALL "entry".
+ DISPLAY "end-main".
+ GOBACK.
+ ENTRY "entry".
+ DISPLAY "entry".
+])
+
+# The next check should fail because the RECURSIVE flag is missing in the
+# previous program, and there is a static call to one of its entries
+
+AT_CHECK([$COMPILE -x prog2.cob], [0])
+
+AT_DATA([prog3.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog3.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 counter PIC 9(1).
+ PROCEDURE DIVISION.
+ DISPLAY "HELLO WORLD".
+ CALL "entry".
+ GOBACK.
+ ENTRY "entry".
+ ADD 1 TO counter.
+ DISPLAY "entry " counter.
+ IF counter < 5 THEN
+ CALL "inside-program"
+ END-IF.
+ GOBACK.
+ PROGRAM-ID. inside-program.
+ PROCEDURE DIVISION.
+ CALL "entry".
+ END PROGRAM inside-program.
+ END PROGRAM prog3.
+])
+
+AT_CHECK([$COMPILE -x prog3.cob])
+
+# The next one is not correct either: 'entry 2' should not be printed,
+# because it results from a recursive call from inside-program to prog3,
+# but it is only detected at the next iteration.
+
+AT_CHECK([./prog3], [1], [HELLO WORLD
+entry 1
+entry 2
+],
+[libcob: prog3.cob:15: error: recursive CALL from 'prog3' to 'inside-program' which is NOT RECURSIVE
+max module iterations exceeded, possible broken chain
+])
+
+# This one should be ok, at least on MicroFocus because LOCAL-STORAGE
+# section implies RECURSIVE for them
+
+AT_DATA([prog4.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog4.
+ DATA DIVISION.
+ LOCAL-STORAGE SECTION.
+ PROCEDURE DIVISION.
+ DISPLAY "main".
+ CALL "entry".
+ DISPLAY "end-main".
+ GOBACK.
+ ENTRY "entry".
+ DISPLAY "entry".
+])
+
+AT_CHECK([$COMPILE -x prog4.cob])
+
+AT_CHECK([./prog4], [0], [main
+entry
+end-main
+])
+
+AT_DATA([prog5.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog5 RECURSIVE.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 counter PIC 9(1).
+ PROCEDURE DIVISION.
+ DISPLAY "HELLO WORLD".
+ CALL "entry".
+ GOBACK.
+ ENTRY "entry".
+ ADD 1 TO counter.
+ DISPLAY "entry " counter.
+ IF counter < 5 THEN
+ CALL "inside-program"
+ END-IF.
+ GOBACK.
+ PROGRAM-ID. inside-program RECURSIVE.
+ PROCEDURE DIVISION.
+ CALL "entry".
+ END PROGRAM inside-program.
+ END PROGRAM prog5.
+])
+
+# There is no reason for this one to fail, it has the RECURSIVE flag...
+# but no IDENTIFICATION DIVISION before the second PROGRAM-ID
+
+AT_CHECK([$COMPILE -x prog5.cob], [1], [],
+[prog5.cob:18: error: syntax error, unexpected Identifier
+])
+AT_DATA([prog5.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog5 RECURSIVE.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 counter PIC 9(1).
+ PROCEDURE DIVISION.
+ DISPLAY "HELLO WORLD".
+ CALL "entry".
+ GOBACK.
+ ENTRY "entry".
+ ADD 1 TO counter.
+ DISPLAY "entry " counter.
+ IF counter < 5 THEN
+ CALL "inside-program"
+ END-IF.
+ GOBACK.
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. inside-program RECURSIVE.
+ PROCEDURE DIVISION.
+ CALL "entry".
+ END PROGRAM inside-program.
+ END PROGRAM prog5.
+])
+
+# Adding the IDENTIFICATION DIVISION makes it work... why ?
+
+AT_CHECK([$COMPILE -x prog5.cob])
+
+AT_CHECK([./prog5], [0], [HELLO WORLD
+entry 1
+entry 2
+entry 3
+entry 4
+entry 5
+])
+
+AT_DATA([prog6.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog6 RECURSIVE.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 counter PIC 9(1).
+ PROCEDURE DIVISION.
+ DISPLAY "HELLO WORLD".
+ CALL "entry".
+ GOBACK.
+ ENTRY "entry".
+ ADD 1 TO counter.
+ DISPLAY "entry " counter.
+ IF counter < 5 THEN
+ CALL "inside-program"
+ END-IF.
+ GOBACK.
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. inside-program.
+ DATA DIVISION.
+ LOCAL-STORAGE SECTION.
+ PROCEDURE DIVISION.
+ CALL "entry".
+ END PROGRAM inside-program.
+ END PROGRAM prog6.
+])
+
+# No LOCAL-STORAGE in nested programs ? Microfocus documentation does
+# not display such a limitation
+
+AT_CHECK([$COMPILE -x prog6.cob], [1], [],
+[prog6.cob:21: error: LOCAL-STORAGE not allowed in nested programs
+])
+
+AT_DATA([prog6.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog6.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 counter PIC 9(1).
+ LOCAL-STORAGE SECTION.
+ PROCEDURE DIVISION.
+ DISPLAY "HELLO WORLD".
+ CALL "entry".
+ GOBACK.
+ ENTRY "entry".
+ ADD 1 TO counter.
+ DISPLAY "entry " counter.
+ IF counter < 5 THEN
+ CALL "inside-program"
+ END-IF.
+ GOBACK.
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. inside-program RECURSIVE.
+ PROCEDURE DIVISION.
+ CALL "entry".
+ END PROGRAM inside-program.
+ END PROGRAM prog6.
+])
+
+# This is ok to run if LOCAL-STORAGE implies RECURSIVE. Note that the
+# need for RECURSIVE on a nested program that is currently not allowed
+# to have a LOCAL-STORAGE section is paradoxal.
+
+AT_CHECK([$COMPILE -x prog6.cob])
+
+# Oups, this one segfaults
+
+AT_CHECK([./prog6], [139], [HELLO WORLD
+entry 1
+entry 2
+entry 3
+entry 4
+entry 5
+],
+[ignore])
+
+# Force failure
+
+AT_XFAIL_IF(true)
+AT_CHECK([false])
+
+AT_CLEANUP
diff --git a/tests/testsuite.src/used_binaries.at b/tests/testsuite.src/used_binaries.at
index b99b7e6f4..b570cafac 100644
--- a/tests/testsuite.src/used_binaries.at
+++ b/tests/testsuite.src/used_binaries.at
@@ -1081,3 +1081,256 @@ HOME/prog.cob:14: warning: ignoring redundant .
AT_CLEANUP
+AT_SETUP([run profiling])
+AT_KEYWORDS([cobc profiling])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ PROCEDURE DIVISION.
+ 1ST SECTION.
+ PARA-0001.
+ PERFORM PARA-0003.
+ PARA-0002.
+ CONTINUE.
+ PARA-0003.
+ GO TO 2ND.
+ PARA-0004.
+ CONTINUE.
+ 2ND SECTION.
+ PARA-0005.
+ PERFORM PARA-0006.
+ PARA-0006.
+ CONTINUE.
+ PARA-0007.
+ STOP RUN.
+])
+AT_CAPTURE_FILE([prof-prog.csv])
+
+AT_CHECK([$COMPILE -fprof -x prog.cob], [0], [],
+[prog.cob: in section '1ST':
+prog.cob: in paragraph 'PARA-0003':
+prog.cob:11: warning: GO TO SECTION '2ND'
+])
+
+AT_CHECK([COB_PROF_ENABLE=1 COB_PROF_FILE='prof-$b.csv' ./prog], [0], [],
+[File prof-prog.csv generated
+])
+
+AT_CHECK([COB_PROF_ENABLE=1 ./prog], [0], [],[ignore])
+
+# note: The time here is actually the number of times the procedure has
+# been run, to avoid any indeterminism in the running time of the
+# procedure.
+
+AT_CHECK([cat prof-prog.csv], [0],
+[program-id,section,paragraph,entry,location,kind,time-ns,time,ncalls
+prog,,,,prog.cob:4,PROGRAM,13000000,0.013 s,1
+prog,1ST,,,prog.cob:5,SECTION,12000000,0.012 s,1
+prog,1ST,PARA-0001,,prog.cob:6,PARAGRAPH,11000000,0.011 s,1
+prog,1ST,PARA-0002,,prog.cob:8,PARAGRAPH,0,0.000 s,0
+prog,1ST,PARA-0003,,prog.cob:10,PARAGRAPH,1000000,0.001 s,1
+prog,1ST,PARA-0004,,prog.cob:12,PARAGRAPH,0,0.000 s,0
+prog,2ND,,,prog.cob:14,SECTION,6000000,0.006 s,1
+prog,2ND,PARA-0005,,prog.cob:15,PARAGRAPH,3000000,0.003 s,1
+prog,2ND,PARA-0006,,prog.cob:17,PARAGRAPH,2000000,0.002 s,2
+prog,2ND,PARA-0007,,prog.cob:19,PARAGRAPH,1000000,0.001 s,1
+])
+
+AT_CLEANUP
+
+AT_SETUP([run profiling with no name])
+AT_KEYWORDS([cobc profiling])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ PROCEDURE DIVISION.
+ DISPLAY "HELLO".
+ DISPLAY "WORLD".
+])
+AT_CAPTURE_FILE([prof.csv])
+
+AT_CHECK([$COMPILE -fprof -x prog.cob])
+
+AT_CHECK([COB_PROF_ENABLE=1 COB_PROF_FILE=prof.csv ./prog], [0], [HELLO
+WORLD
+],
+[File prof.csv generated
+])
+
+AT_CHECK([cat prof.csv], [0],
+[program-id,section,paragraph,entry,location,kind,time-ns,time,ncalls
+prog,,,,prog.cob:4,PROGRAM,3000000,0.003 s,1
+prog,MAIN SECTION,,,prog.cob:5,SECTION,1000000,0.001 s,1
+prog,MAIN SECTION,MAIN PARAGRAPH,,prog.cob:5,PARAGRAPH,1000000,0.001 s,1
+])
+
+AT_CLEANUP
+
+AT_SETUP([run profiling with no section])
+AT_KEYWORDS([cobc profiling])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ PROCEDURE DIVISION.
+ 1ST.
+ DISPLAY "HELLO".
+ 2ND.
+ DISPLAY "WORLD".
+])
+AT_CAPTURE_FILE([prof.csv])
+
+AT_CHECK([$COMPILE -fprof -x prog.cob])
+
+AT_CHECK([COB_PROF_ENABLE=1 COB_PROF_FILE=prof.csv ./prog], [0], [HELLO
+WORLD
+],
+[File prof.csv generated
+])
+
+AT_CHECK([cat prof.csv], [0],
+[program-id,section,paragraph,entry,location,kind,time-ns,time,ncalls
+prog,,,,prog.cob:4,PROGRAM,5000000,0.005 s,1
+prog,MAIN SECTION,,,prog.cob:5,SECTION,2000000,0.002 s,1
+prog,MAIN SECTION,1ST,,prog.cob:5,PARAGRAPH,1000000,0.001 s,1
+prog,MAIN SECTION,2ND,,prog.cob:7,PARAGRAPH,1000000,0.001 s,1
+])
+
+AT_CLEANUP
+
+AT_SETUP([run profiling with recursion, entries and CALL])
+AT_KEYWORDS([cobc])
+
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog RECURSIVE.
+ PROCEDURE DIVISION.
+ DISPLAY "HELLO WORLD".
+ CALL "entry".
+ GOBACK.
+ ENTRY "entry".
+ CALL "inside-program".
+ PROGRAM-ID. inside-program.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 COUNTER PIC 9(4).
+ PROCEDURE DIVISION.
+ MAIN SECTION.
+ MOVE 100 TO COUNTER.
+ INSIDE SECTION.
+ PERFORM ITER.
+ EXIT SECTION.
+ ITER.
+ IF COUNTER = 0
+ DISPLAY "end iter"
+ EXIT PARAGRAPH.
+ SUBTRACT 1 FROM COUNTER.
+ PERFORM INSIDE.
+ END PROGRAM inside-program.
+ END PROGRAM prog.
+])
+AT_CAPTURE_FILE([prof.csv])
+
+AT_CHECK([$COMPILE -fprof -x prog.cob])
+
+AT_CHECK([COB_PROF_ENABLE=1 COB_PROF_FILE=prof.csv ./prog], [0],
+[HELLO WORLD
+end iter
+],
+[File prof.csv generated
+])
+
+AT_CHECK([cat prof.csv], [0],
+[program-id,section,paragraph,entry,location,kind,time-ns,time,ncalls
+inside__program,,,,prog.cob:14,PROGRAM,407000000,0.407 s,1
+inside__program,MAIN,,,prog.cob:15,SECTION,1000000,0.001 s,1
+inside__program,MAIN,MAIN PARAGRAPH,,prog.cob:15,PARAGRAPH,1000000,0.001 s,1
+inside__program,INSIDE,,,prog.cob:17,SECTION,804000000,0.804 s,101
+inside__program,INSIDE,MAIN PARAGRAPH,,prog.cob:17,PARAGRAPH,403000000,0.403 s,101
+inside__program,INSIDE,ITER,,prog.cob:20,PARAGRAPH,401000000,0.401 s,101
+prog,,,,prog.cob:4,PROGRAM,419000000,0.419 s,2
+prog,MAIN SECTION,,,prog.cob:5,SECTION,417000000,0.417 s,1
+prog,MAIN SECTION,MAIN PARAGRAPH,,prog.cob:5,PARAGRAPH,417000000,0.417 s,2
+prog,MAIN SECTION,MAIN PARAGRAPH,entry,prog.cob:6,CALL,415000000,0.415 s,1
+prog,MAIN SECTION,MAIN PARAGRAPH,entry,prog.cob:8,ENTRY,0,0.000 s,1
+prog,MAIN SECTION,MAIN PARAGRAPH,inside-program,prog.cob:9,CALL,409000000,0.409 s,1
+])
+
+AT_CLEANUP
+
+
+
+
+
+AT_SETUP([profiling two modules with CALL])
+AT_KEYWORDS([cobc])
+
+AT_DATA([prog1.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog1.
+ DATA DIVISION.
+ LOCAL-STORAGE SECTION.
+ 01 COUNTER PIC 9(4).
+ 01 PARAM PIC 9.
+ 01 CALL-NAME PIC X(10).
+ PROCEDURE DIVISION.
+ MOVE 'prog2' TO CALL-NAME.
+ PERFORM CALL-PROG2
+ VARYING COUNTER FROM 0 BY 1
+ UNTIL COUNTER = 300.
+ GOBACK.
+ CALL-PROG2.
+ MOVE 1 TO PARAM.
+ CALL "prog2" USING PARAM.
+ MOVE 2 TO PARAM.
+ CALL CALL-NAME USING PARAM.
+ END PROGRAM prog1.
+])
+AT_DATA([prog2.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog2.
+ DATA DIVISION.
+ LINKAGE SECTION.
+ 01 PARAM PIC 9.
+ PROCEDURE DIVISION USING PARAM.
+ DISPLAYER SECTION.
+ IF PARAM = 1
+ DISPLAY "X" NO ADVANCING
+ ELSE
+ PERFORM OTHER-DISPLAY.
+ GOBACK.
+ OTHER-DISPLAY SECTION.
+ DISPLAY "Y" NO ADVANCING.
+ END PROGRAM prog2.
+])
+AT_CAPTURE_FILE([prof.csv])
+
+AT_CHECK([$COMPILE -fprof prog1.cob])
+
+AT_CHECK([$COMPILE_MODULE -fprof prog2.cob])
+
+AT_CHECK([COB_PROF_ENABLE=1 COB_PROF_FILE=prof.csv ./prog1], [0],
+[XYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXY],
+[File prof.csv generated
+])
+
+AT_CHECK([cat prof.csv], [0],
+[program-id,section,paragraph,entry,location,kind,time-ns,time,ncalls
+prog2,,,,prog2.cob:7,PROGRAM,2400000000,2.400 s,600
+prog2,DISPLAYER,,,prog2.cob:8,SECTION,1200000000,1.200 s,600
+prog2,DISPLAYER,MAIN PARAGRAPH,,prog2.cob:8,PARAGRAPH,1200000000,1.200 s,600
+prog2,OTHER-DISPLAY,,,prog2.cob:14,SECTION,300000000,0.300 s,300
+prog2,OTHER-DISPLAY,MAIN PARAGRAPH,,prog2.cob:14,PARAGRAPH,300000000,0.300 s,300
+prog1,,,,prog1.cob:9,PROGRAM,4803000000,4.803 s,1
+prog1,MAIN SECTION,,,prog1.cob:10,SECTION,9301000000,9.301 s,1
+prog1,MAIN SECTION,MAIN PARAGRAPH,,prog1.cob:10,PARAGRAPH,4801000000,4.801 s,1
+prog1,MAIN SECTION,CALL-PROG2,,prog1.cob:15,PARAGRAPH,4500000000,4.500 s,300
+prog1,MAIN SECTION,CALL-PROG2,prog2,prog1.cob:17,CALL,1500000000,1.500 s,300
+prog1,MAIN SECTION,CALL-PROG2,(dynamic),prog1.cob:19,CALL,2100000000,2.100 s,300
+])
+
+AT_CLEANUP
+
+