From 168766675560708822251c046230d1feadce8b95 Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Fri, 10 Nov 2023 17:25:18 +0100 Subject: [PATCH] Add -fprof option to profile in time to CSV file Initial work by Emilien Lemaire Additional features: * Do not check for enter/exit section: instead, sum time from paragraphs * Support for modules, CALL and ENTRY points * Support for recursive calls * Allocate virtual stack on demand instead of statically * Correct handling of EXIT PARAGRAPH code with 'goto' * Prevent CANCEL from dlclose a module during profiling * Customize CSV result file with COB_PROF_FORMAT * Customize CSV filename using $b/$f/$d/$t * Add some tests for RECURSIVE on PROGRAM-ID --- NEWS | 13 + cobc/ChangeLog | 19 ++ cobc/codegen.c | 120 ++++++- cobc/flag.def | 4 + cobc/parser.y | 75 ++++- cobc/tree.c | 185 ++++++++++- cobc/tree.h | 53 ++- cobc/typeck.c | 10 +- config/ChangeLog | 4 + config/runtime.cfg | 54 +++- doc/ChangeLog | 4 + doc/gnucobol.texi | 102 +++++- libcob/ChangeLog | 13 + libcob/Makefile.am | 2 +- libcob/coblocal.h | 10 + libcob/common.c | 277 ++++++++++------ libcob/common.h | 62 +++- libcob/profiling.c | 558 ++++++++++++++++++++++++++++++++ tests/testsuite.src/run_misc.at | 407 +++++++++++++++++++++++ 19 files changed, 1852 insertions(+), 120 deletions(-) create mode 100644 libcob/profiling.c diff --git a/NEWS b/NEWS index 1d116c6f6..e8a082b4c 100644 --- a/NEWS +++ b/NEWS @@ -13,6 +13,13 @@ NEWS - user visible changes -*- outline -*- ** support the COLLATING SEQUENCE clause on indexed files (currently only with the BDB backend) +** Support 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 @@ -55,6 +62,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/cobc/ChangeLog b/cobc/ChangeLog index 61f1ceae4..f95300de1 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,23 @@ +2024-03-17 Fabrice Le Fessant + 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 + * tree.h: add a flags field to cb_goto, add profiling + fields to cb_program, add cb_prof_call enum and export + cb_build_prof_call and cb_prof_procedure_fivision functions + * tree.c (cb_build_program): initialize the new profiling + fields of the cb_program structure + * tree.c (cb_build_goto): add a "flags" argument + (stored in the cb_program structure) + * typeck.c (cb_emit_goto): add a "flags" argument + (passed to cb_build_goto) + * codegen.c: handle profiling code generation under the + cb_flag_prof guard + 2024-02-19 Boris Eng * parser.y (screen_value_clause): replaced basic literals by literals diff --git a/cobc/codegen.c b/cobc/codegen.c index c7dd66d17..7e6e26867 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -4328,7 +4328,6 @@ output_funcall_item (cb_tree x, const int i, unsigned int func_nolitcast) output_param (x, i); } - static void output_funcall (cb_tree x) { @@ -4344,6 +4343,61 @@ 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);", proc_idx); + output_newline (); + output_prefix (); + output ("cob_prof_fallthrough_label = 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_label)"); + output_block_open (); + output_line ("cob_prof_use_paragraph_entry (prof_info, %d, %d);", + paragraph_idx, entry_idx); + output_block_close (); + output_line ("else"); + output_block_open (); + output_line ("cob_prof_fallthrough_label = 0;"); + output_block_close (); + break; + } + case COB_PROF_STAYIN_PARAGRAPH: + output ("cob_prof_fallthrough_label = 1"); + break; + } + return; + } + + screenptr = p->screenptr; output ("%s (", p->name); for (i = 0; i < p->argc; i++) { @@ -7936,6 +7990,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 */ @@ -12256,6 +12317,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 */; @@ -12350,7 +12424,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) {"); @@ -13679,6 +13755,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_label = 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) { @@ -13954,6 +14069,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 ea7f0c98a..ff2a175ec 100644 --- a/cobc/flag.def +++ b/cobc/flag.def @@ -262,3 +262,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 c6b82bf1f..6cb5fd120 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -383,6 +383,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) @@ -2092,8 +2107,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 = ""; @@ -2104,7 +2119,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 @@ -10873,6 +10894,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 @@ -10915,12 +10942,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)); } } @@ -10947,6 +10976,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; @@ -10957,6 +10988,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: @@ -11235,6 +11270,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; } @@ -11243,6 +11279,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; } @@ -11319,12 +11356,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) { @@ -11349,6 +11388,7 @@ section_header: _use_statement { emit_statement (CB_TREE (current_section)); + emit_prof_call (COB_PROF_ENTER_SECTION, NULL, NULL); } ; @@ -11372,6 +11412,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 ( @@ -11391,6 +11432,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; @@ -11398,6 +11440,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); } ; @@ -11500,6 +11543,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"); @@ -11513,6 +11557,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) { @@ -11614,7 +11659,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); @@ -12404,6 +12449,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; @@ -12429,10 +12475,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")); @@ -12496,6 +12543,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); } ; @@ -13877,6 +13927,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; } @@ -13915,6 +13966,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 ); } } ; @@ -14407,7 +14460,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; } } @@ -14430,7 +14483,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; } } @@ -14451,7 +14504,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; } } @@ -14472,7 +14525,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; } } @@ -14557,13 +14610,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 2502e3a8f..a49d8aaf0 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 @@ -6671,7 +6676,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; @@ -6679,6 +6684,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); } @@ -7460,6 +7466,183 @@ cb_deciph_default_file_colseq_name (const char * const name) return cb_deciph_colseq_name (name, &cb_default_file_colseq); } +/* Use constant strings to replace string comparisons by more + * efficient pointer comparisons */ +const char *cob_prof_function_call_str = "cob_prof_function_call"; + +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->orig_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 = -1; + 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)); +} + +/* 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. */ +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; +} #ifndef HAVE_DESIGNATED_INITS void diff --git a/cobc/tree.h b/cobc/tree.h index f9302a2ec..5b1be1ba6 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); @@ -2464,7 +2481,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); @@ -2612,6 +2629,38 @@ 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 const char *cob_prof_function_call_str; + +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); + +extern int procedure_list_add (struct cb_program *program, + enum cob_prof_procedure_kind kind, + const char *text, + int section, + 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/ChangeLog b/config/ChangeLog index f6b76e3e2..ce0049963 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -3,6 +3,10 @@ * rm-strict.conf (perform-osvs): enabled as noted in MF docs +2023-09-07 Emilien Lemaire + + * runtime.cfg: add COB_PROF_FILE + 2023-07-25 Simon Sobisch * general: add option using-optional diff --git a/config/runtime.cfg b/config/runtime.cfg index a8e22276e..b076f2298 100644 --- a/config/runtime.cfg +++ b/config/runtime.cfg @@ -69,6 +69,15 @@ # A 'size' value is an unsigned integer optionally followed by K, M, or G # for kilo, mega or giga. +# Variables of type string can be of three different kinds: +# regular string, file name, and path list +# All those may contain the following escape sequences: +# $$ process id +# $f executable filename (full path) +# $b executable basename (anything after the last separator) +# $d date (yyyymmdd) +# $t time (hhmmss) + # For convenience a parameter in the runtime.cfg file may be defined by using # either the environment variable name or the parameter name. # In most cases the environment variable name is the parameter name (in upper @@ -119,7 +128,7 @@ # Environment name: COB_TRACE_FILE # Parameter name: trace_file # Purpose: to define where COBOL trace output should go -# Type: string : $$ is replaced by process id +# Type: string (file) ; may use $-sequences # Note: file is opened for append if name starts with "+" # Default: stderr # Example: TRACE_FILE ${HOME}/mytrace.$$ @@ -195,7 +204,7 @@ # Note: the -fdump=all compile option prepares for dump; # file is opened for append if name starts with "+"; # may be disabled by setting it to "NONE" -# Type: string : $$ is replaced by process id +# Type: string (file) ; may use $-sequences # Default: stderr # Example: DUMP_FILE ${HOME}/mytrace.log @@ -217,6 +226,41 @@ # Example: COB_CURRENT_DATE "2026/03/16 16:40:52" # current_date YYYYMMDDHHMMSS+01:00 +# Environment name: COB_PROF_FILE +# Parameter name: prof_file +# Purpose: to define where COBOL profiling output should go +# Type: string (file) ; may use $-sequences +# 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; +# note that this disables physical cancel +# 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 # @@ -224,7 +268,7 @@ # Environment name: COB_LIBRARY_PATH # Parameter name: library_path # Purpose: paths for dynamically-loadable modules -# Type: string +# Type: string (path list) # Note: the default paths .:/installpath/extras are always # added to the given paths # Example: LIBRARY_PATH /opt/myapp/test:/opt/myapp/production @@ -467,7 +511,7 @@ # Parameter name: display_print_file # Purpose: Defines file to be appended to by DISPLAY UPON PRINTER # Note: Each DISPLAY UPON PRINTER opens, appends and closes the file. -# Type: string : $$ is replaced by process id +# Type: string ; may use $-sequences # Default: not set # Example: display_printer '/tmp/myprt.log' @@ -476,7 +520,7 @@ # Purpose: Defines file to be created on first # DISPLAY UPON SYSPUNCH/SYSPCH # Note: The file will be only be closed on runtime exit. -# Type: string : $$ is replaced by process id +# Type: string ; may use $-sequences # Default: not set # Example: display_punch './punch_$$.out' diff --git a/doc/ChangeLog b/doc/ChangeLog index 6370af4f0..6934379cf 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,4 +1,8 @@ +2023-09-07 Emilien Lemaire + + * gnucobol.texi: document the profiling feature + 2023-07-10 Simon Sobisch * gnucobol.texi: updated "Build target" (change of -P / -E), diff --git a/doc/gnucobol.texi b/doc/gnucobol.texi index 41127428a..af4eb9fd2 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. @@ -1734,7 +1739,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 @@ -1795,7 +1800,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 5f7f8b9ea..14bed86a2 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,17 @@ +2024-03-17 Fabrice Le Fessant + 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) + * common.c (cob_set_main_argv0): extracted from cob_init + 2024-01-25 David Declerck FR #459: support COLLATING SEQUENCE clause on SELECT / INDEXED files diff --git a/libcob/Makefile.am b/libcob/Makefile.am index ce5a4a5cc..f3fb2343e 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 if LOCAL_CJSON nodist_libcob_la_SOURCES = cJSON.c diff --git a/libcob/coblocal.h b/libcob/coblocal.h index 23bd23227..51fe7565b 100644 --- a/libcob/coblocal.h +++ b/libcob/coblocal.h @@ -347,6 +347,10 @@ 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_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,6 +445,7 @@ 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); @@ -504,6 +509,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, @@ -573,6 +581,8 @@ cob_max_int (const int x, const int y) COB_HIDDEN int cob_cmps (const unsigned char *, const unsigned char *, const size_t, const unsigned char *); +COB_HIDDEN FILE * cob_open_logfile (const char *filename); + #undef COB_HIDDEN #endif /* COB_LOCAL_H */ diff --git a/libcob/common.c b/libcob/common.c index bdf4e9c13..aa2c2968e 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -503,9 +503,13 @@ static struct config_tbl gc_conf[] = { {"COB_TRACE_FORMAT", "trace_format", "%P %S Line: %L", NULL, GRP_MISC, ENV_STR, SETPOS (cob_trace_format)}, {"COB_STACKTRACE", "stacktrace", "1", NULL, GRP_MISC, ENV_BOOL, SETPOS (cob_stacktrace)}, {"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_CORE_FILENAME", "core_filename", "./core.libcob", NULL, GRP_MISC, ENV_FILE, SETPOS (cob_core_filename)}, {"COB_DUMP_FILE", "dump_file", NULL, NULL, GRP_MISC, ENV_FILE, SETPOS (cob_dump_filename)}, {"COB_DUMP_WIDTH", "dump_width", "100", NULL, GRP_MISC, ENV_UINT, SETPOS (cob_dump_width)}, + {"COB_PROF_ENABLE", "prof_enable", "0", NULL, GRP_MISC, ENV_BOOL, SETPOS (cob_prof_enable)}, + {"COB_PROF_FILE", "prof_file", "cob-prof-$b-$$-$d-$t.csv", NULL, GRP_MISC, ENV_FILE, SETPOS (cob_prof_filename)}, + {"COB_PROF_FORMAT", "prof_format", "%m,%s,%p,%e,%w,%k,%t,%h,%n", NULL, GRP_MISC, ENV_STR, SETPOS (cob_prof_format)}, + {"COB_PROF_MAX_DEPTH", "prof_max_depth", "8192", NULL, GRP_MISC, ENV_UINT, SETPOS (cob_prof_max_depth)}, #ifdef _WIN32 /* checked before configuration load if set from environment in cob_common_init() */ {"COB_UNIX_LF", "unix_lf", "0", NULL, GRP_FILE, ENV_BOOL, SETPOS (cob_unix_lf)}, @@ -522,7 +526,7 @@ static struct config_tbl gc_conf[] = { #if defined (_WIN32) && !defined (__MINGW32__) {"OS", "ostype", NULL, NULL, GRP_SYSENV, ENV_STR, SETPOS (cob_sys_type)}, #endif - {"COB_FILE_PATH", "file_path", NULL, NULL, GRP_FILE, ENV_PATH, SETPOS (cob_file_path)}, + {"COB_FILE_PATH", "file_path", NULL, NULL, GRP_FILE, ENV_FILE, SETPOS (cob_file_path)}, {"COB_VARSEQ_FORMAT", "varseq_format", varseq_dflt, varseqopts, GRP_FILE, ENV_UINT | ENV_ENUM, SETPOS (cob_varseq_type)}, {"COB_LS_FIXED", "ls_fixed", "0", NULL, GRP_FILE, ENV_BOOL, SETPOS (cob_ls_fixed)}, {"STRIP_TRAILING_SPACES", "strip_trailing_spaces", NULL, NULL, GRP_HIDE, ENV_BOOL | ENV_NOT, SETPOS (cob_ls_fixed)}, @@ -540,8 +544,8 @@ static struct config_tbl gc_conf[] = { {"COB_COL_JUST_LRC", "col_just_lrc", "true", NULL, GRP_FILE, ENV_BOOL, SETPOS (cob_col_just_lrc)}, {"COB_DISPLAY_PRINT_PIPE", "display_print_pipe", NULL, NULL, GRP_SCREEN, ENV_STR, SETPOS (cob_display_print_pipe)}, {"COBPRINTER", "printer", NULL, NULL, GRP_HIDE, ENV_STR, SETPOS (cob_display_print_pipe)}, - {"COB_DISPLAY_PRINT_FILE", "display_print_file", NULL, NULL, GRP_SCREEN, ENV_STR,SETPOS (cob_display_print_filename)}, - {"COB_DISPLAY_PUNCH_FILE", "display_punch_file", NULL, NULL, GRP_SCREEN, ENV_STR,SETPOS (cob_display_punch_filename)}, + {"COB_DISPLAY_PRINT_FILE", "display_print_file", NULL, NULL, GRP_SCREEN, ENV_FILE,SETPOS (cob_display_print_filename)}, + {"COB_DISPLAY_PUNCH_FILE", "display_punch_file", NULL, NULL, GRP_SCREEN, ENV_FILE,SETPOS (cob_display_punch_filename)}, {"COB_LEGACY", "legacy", NULL, NULL, GRP_SCREEN, ENV_BOOL, SETPOS (cob_legacy)}, {"COB_EXIT_WAIT", "exit_wait", "1", NULL, GRP_SCREEN, ENV_BOOL, SETPOS (cob_exit_wait)}, {"COB_EXIT_MSG", "exit_msg", NULL, NULL, GRP_SCREEN, ENV_STR, SETPOS (cob_exit_msg)}, /* default set in cob_init_screenio() */ @@ -812,6 +816,7 @@ cob_terminate_routines (void) } fflush (stderr); + cob_prof_end(); cob_exit_fileio_msg_only (); if (COB_MODULE_PTR && abort_reason[0] != 0) { @@ -2094,7 +2099,7 @@ cob_move_to_group_as_alnum (cob_field *src, cob_field *dst) /* open file using mode according to cob_unix_lf and filename (append when starting with +) */ -static FILE * +FILE * cob_open_logfile (const char *filename) { const char *mode; @@ -7746,17 +7751,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 +7858,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 +10142,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 +10152,87 @@ 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); +#endif +#ifdef HAVE_READLINK + 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"; + } else { + path = NULL; + } + 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 +10282,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)); @@ -10188,6 +10359,7 @@ cob_init (const int argc, char **argv) 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 +10409,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 0bda18a5f..32e09c194 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -1722,7 +1722,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 *); @@ -2954,4 +2954,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/profiling.c b/libcob/profiling.c new file mode 100644 index 000000000..630e5276a --- /dev/null +++ b/libcob/profiling.c @@ -0,0 +1,558 @@ +/* + Copyright (C) 2023-2024 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 +#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; + +/* Which clock to use for clock_gettime (if available) */ +#if !defined (_WIN32) && defined (HAVE_CLOCK_GETTIME) +static clockid_t clockid = CLOCK_REALTIME; +#endif + +/* Cached clock frequency on Windows */ +#ifdef _WIN32 +static LONGLONG qpc_freq = 0; +#endif + +/* 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) +{ + if (is_test){ + static cob_ns_time ns_time = 0; + ns_time += 1000000; + return ns_time; + } else { + cob_ns_time ns_time = 0; + unsigned long long nanoseconds; +#ifdef _WIN32 + if (qpc_freq) { + LARGE_INTEGER performance_counter; + QueryPerformanceCounter(&performance_counter); + performance_counter.QuadPart *= 1000000000; + performance_counter.QuadPart /= qpc_freq; + nanoseconds = performance_counter.QuadPart; + } else { +#endif /* _WIN32 */ +#ifdef HAVE_CLOCK_GETTIME + struct timespec ts; + clock_gettime(clockid, &ts); + nanoseconds = ts.tv_sec * 1000000000 + ts.tv_nsec; +#else + nanoseconds = clock() * 1000000000 / CLOCKS_PER_SEC; +#endif /* HAVE_CLOCK_GETTIME */ +#ifdef _WIN32 + } +#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){ +#ifdef HAVE_CLOCK_GETTIME + struct timespec ts; + if (clock_gettime(CLOCK_MONOTONIC_RAW, &ts) == 0) { + clockid = CLOCK_MONOTONIC_RAW; + } else if (clock_gettime(CLOCK_MONOTONIC, &ts) == 0) { + clockid = CLOCK_MONOTONIC; + } +#endif +#ifdef _WIN32 + /* Should always succeed on Windows XP and above, but might + fail on Windows 2000. Not available on Windows 9x & NT. */ + LARGE_INTEGER performance_frequency; + if (QueryPerformanceFrequency(&performance_frequency)) { + qpc_freq = performance_frequency.QuadPart; + } +#endif + 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; + cob_runtime_warning (_("[cob_prof] Profiling overflow at %d calls, aborting profiling."), current_idx); + cob_runtime_warning (_(" Last 10 calls on stack:")); + for (i = 0; i < cob_min_int(10, current_idx); 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; + cob_runtime_warning (_(" * %s at %s:%d"), 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 = NULL; + const char *section = NULL; + const char *paragraph = NULL; + const char *entry = NULL; + const char *kind = NULL; + const char *source_file; + int line; + int ncalls; + cob_ns_time time = 0; + 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){ + if (is_test){ + fprintf (file, "%d", 42); + } else { + 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; + 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]); + } + + file = cob_open_logfile (cobsetptr->cob_prof_filename); + + 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", cobsetptr->cob_prof_filename); + } else { + cob_runtime_warning (_("error '%s' opening COB_PROF_FILE '%s'"), + cob_get_strerror (), cobsetptr->cob_prof_filename); + } + current_idx = -1; + is_active = 0; +} diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index 18b32583d..1e0534d57 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -14631,3 +14631,410 @@ AT_DATA([prog.cob], [ AT_CHECK([$COMPILE_MODULE prog.cob], [0], [], []) AT_CHECK([$COBCRUN prog], [0], [OKOKOKOKOK], []) 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 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' $COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CHECK([$COMPILE -fprof 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=0 COB_PROF_FILE='prof-$b.csv' $COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CHECK([COB_PROF_ENABLE=1 COB_PROF_FILE='prof-$b.csv' COB_PROF_FORMAT=%i,%m,%s,%p,%e,%f,%l,%w,%k,%t,%h,%n,%x $COBCRUN_DIRECT ./prog], [0], [], +[File prof-prog.csv generated +]) + +# 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], +[pid,program-id,section,paragraph,entry,file,line,location,kind,time-ns,time,ncalls,%x +42,prog,,,,prog.cob,4,prog.cob:4,PROGRAM,13000000,0.013 s,1,%x +42,prog,1ST,,,prog.cob,5,prog.cob:5,SECTION,12000000,0.012 s,1,%x +42,prog,1ST,PARA-0001,,prog.cob,6,prog.cob:6,PARAGRAPH,11000000,0.011 s,1,%x +42,prog,1ST,PARA-0002,,prog.cob,8,prog.cob:8,PARAGRAPH,0,0.000 s,0,%x +42,prog,1ST,PARA-0003,,prog.cob,10,prog.cob:10,PARAGRAPH,1000000,0.001 s,1,%x +42,prog,1ST,PARA-0004,,prog.cob,12,prog.cob:12,PARAGRAPH,0,0.000 s,0,%x +42,prog,2ND,,,prog.cob,14,prog.cob:14,SECTION,6000000,0.006 s,1,%x +42,prog,2ND,PARA-0005,,prog.cob,15,prog.cob:15,PARAGRAPH,3000000,0.003 s,1,%x +42,prog,2ND,PARA-0006,,prog.cob,17,prog.cob:17,PARAGRAPH,2000000,0.002 s,2,%x +42,prog,2ND,PARA-0007,,prog.cob,19,prog.cob:19,PARAGRAPH,1000000,0.001 s,1,%x +]) + +AT_CLEANUP + + +AT_SETUP([run profiling with no paragraph/section names]) +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 prog.cob]) + +AT_CHECK([COB_PROF_ENABLE=1 COB_PROF_FILE=prof.csv $COBCRUN_DIRECT ./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 names]) +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 prog.cob]) + +AT_CHECK([COB_PROF_ENABLE=1 COB_PROF_FILE=prof.csv $COBCRUN_DIRECT ./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([profiling depth overflow]) +AT_KEYWORDS([cobc]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + MAIN. + PERFORM PARA. + STOP RUN. + PARA. + DISPLAY "OK" WITH NO ADVANCING. +]) + +AT_CHECK([$COMPILE -fprof prog.cob]) + +AT_CHECK([COB_PROF_MAX_DEPTH=2 COB_PROF_ENABLE=1 COB_PROF_FILE=prof.csv $COBCRUN_DIRECT ./prog], [0], [OK], +[libcob: prog.cob:8: warning: [[cob_prof]] Profiling overflow at 2 calls, aborting profiling. +libcob: prog.cob:8: warning: Last 10 calls on stack: +libcob: prog.cob:8: warning: * MAIN at prog.cob:5 +libcob: prog.cob:8: warning: * prog at prog.cob:4 +]) + +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 prog.cob]) + +AT_CHECK([COB_PROF_ENABLE=1 COB_PROF_FILE=prof.csv $COBCRUN_DIRECT ./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 prog2.cob]) + +AT_CHECK([COB_PROF_ENABLE=1 COB_PROF_FILE=prof.csv $COBCRUN_DIRECT ./prog1], [0], +[XYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXYXY], +[File prof.csv generated +]) + +AT_CHECK([cat prof.csv], [0], +[program-id,section,paragraph,entry,location,kind,time-ns,time,ncalls +prog1,,,,prog1.cob:9,PROGRAM,1803000000,1.803 s,1 +prog1,MAIN SECTION,,,prog1.cob:10,SECTION,3301000000,3.301 s,1 +prog1,MAIN SECTION,MAIN PARAGRAPH,,prog1.cob:10,PARAGRAPH,1801000000,1.801 s,1 +prog1,MAIN SECTION,CALL-PROG2,,prog1.cob:15,PARAGRAPH,1500000000,1.500 s,300 +prog1,MAIN SECTION,CALL-PROG2,prog2,prog1.cob:17,CALL,300000000,0.300 s,300 +prog1,MAIN SECTION,CALL-PROG2,(dynamic),prog1.cob:19,CALL,300000000,0.300 s,300 +]) + +AT_CHECK([$COMPILE_MODULE -fprof prog2.cob]) + +AT_CHECK([COB_PROF_ENABLE=1 COB_PROF_FILE=prof.csv $COBCRUN_DIRECT ./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 + + +AT_SETUP([profiling multiple programs]) +AT_KEYWORDS([cobc]) + +AT_DATA([prog1.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog1. + DATA DIVISION. + PROCEDURE DIVISION. + CALL "SYSTEM" USING "./prog2" + GOBACK. +]) +AT_DATA([prog2.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog2. + PROCEDURE DIVISION. + MAIN. + SET ENVIRONMENT "COB_PROF_FILE" TO "prof2.csv" + PERFORM PARA 5 TIMES. + GOBACK. + PARA. + CONTINUE. +]) +AT_CAPTURE_FILE([prof1.csv]) +AT_CAPTURE_FILE([prof2.csv]) + +AT_CHECK([$COMPILE_MODULE -fprof prog1.cob]) + +AT_CHECK([$COMPILE -fprof prog2.cob]) + +AT_CHECK([COB_PROF_ENABLE=1 COB_PROF_FILE=prof1.csv $COBCRUN ./prog1], [0], [], +[File prof2.csv generated +File prof1.csv generated +]) + +AT_CHECK([cat prof1.csv], [0], +[program-id,section,paragraph,entry,location,kind,time-ns,time,ncalls +prog1,,,,prog1.cob:5,PROGRAM,5000000,0.005 s,1 +prog1,MAIN SECTION,,,prog1.cob:6,SECTION,3000000,0.003 s,1 +prog1,MAIN SECTION,MAIN PARAGRAPH,,prog1.cob:6,PARAGRAPH,3000000,0.003 s,1 +prog1,MAIN SECTION,MAIN PARAGRAPH,SYSTEM,prog1.cob:6,CALL,1000000,0.001 s,1 +]) + +AT_CHECK([cat prof2.csv], [0], +[program-id,section,paragraph,entry,location,kind,time-ns,time,ncalls +prog2,,,,prog2.cob:4,PROGRAM,13000000,0.013 s,1 +prog2,MAIN SECTION,,,prog2.cob:5,SECTION,16000000,0.016 s,1 +prog2,MAIN SECTION,MAIN,,prog2.cob:5,PARAGRAPH,11000000,0.011 s,1 +prog2,MAIN SECTION,PARA,,prog2.cob:9,PARAGRAPH,5000000,0.005 s,5 +]) + +AT_CLEANUP + + +AT_SETUP([profiling out of test mode]) +AT_KEYWORDS([cobc]) + +AT_DATA([caller.c], [[ +#include +#include + +#ifndef NULL +#define NULL (void*)0 +#endif + +int +main (int argc, char **argv) +{ + int i; + + unsetenv("COB_IS_RUNNING_IN_TESTMODE"); + + cob_init (argc, argv); + + for (i = 0; i < 300; ++i) { + cob_call ("callee", 0, NULL); + } + + cob_tidy (); + + return 0; +} +]]) + +AT_DATA([callee.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. callee. + PROCEDURE DIVISION. + MAIN. + PERFORM PARA 5 TIMES. + GOBACK. + PARA. + CONTINUE. +]) +AT_CAPTURE_FILE([prof.csv]) + +AT_CHECK([$COMPILE caller.c]) +AT_CHECK([$COMPILE_MODULE -fprof callee.cob]) +AT_CHECK([COB_PROF_ENABLE=1 COB_PROF_FILE=prof.csv $COBCRUN_DIRECT ./caller], [0], [], [File prof.csv generated +]) + +AT_CLEANUP