From 620148174d65e8a4c61d9c8458f0af1175c0da92 Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Fri, 10 Nov 2023 17:25:18 +0100 Subject: [PATCH 1/3] 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 | 8 + cobc/codegen.c | 293 ++++++++++++++- cobc/flag.def | 4 + cobc/parser.y | 75 +++- cobc/tree.c | 8 +- cobc/tree.h | 44 ++- cobc/typeck.c | 10 +- config/runtime.cfg | 36 ++ doc/ChangeLog | 4 + doc/gnucobol.texi | 102 ++++- libcob/ChangeLog | 10 + libcob/Makefile.am | 2 +- libcob/coblocal.h | 8 + libcob/common.c | 265 ++++++++----- libcob/common.h | 62 +++- libcob/profiling.c | 533 +++++++++++++++++++++++++++ tests/ChangeLog | 4 + tests/testsuite.src/syn_misc.at | 255 +++++++++++++ tests/testsuite.src/used_binaries.at | 251 +++++++++++++ 20 files changed, 1878 insertions(+), 109 deletions(-) create mode 100644 libcob/profiling.c 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/cobc/ChangeLog b/cobc/ChangeLog index d249d3f50..42474654d 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,3 +1,11 @@ +2023-09-04 Fabrice Le Fessant 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..2111fc176 100644 --- a/config/runtime.cfg +++ b/config/runtime.cfg @@ -217,6 +217,42 @@ # 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 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..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 27f8de170..9cc5e3b2e 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, diff --git a/libcob/common.c b/libcob/common.c index 9dacd1d94..0bf64f382 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -505,6 +505,10 @@ 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_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 +816,7 @@ cob_terminate_routines (void) } fflush (stderr); + cob_prof_end(); cob_exit_fileio_msg_only (); if (COB_MODULE_PTR && abort_reason[0] != 0) { @@ -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,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 +10280,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 +10357,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 +10407,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..c87023951 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -1724,7 +1724,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 *); @@ -2956,4 +2956,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..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..f97f81468 100644 --- a/tests/testsuite.src/used_binaries.at +++ b/tests/testsuite.src/used_binaries.at @@ -1081,3 +1081,254 @@ 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 +]) + +# 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 + + From 1501659dc88ec6c1d58cea5e6a457f4fbfb83da9 Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Wed, 20 Mar 2024 10:57:02 +0100 Subject: [PATCH 2/3] Add support for JOR files JOR files are journals of COBOL executions. This commit implements minimalist support for JOR files with the following features: * extensible: the format can be easily extended in the future * compact: the format is binary and does not take too much space on disk Currently, the JOR file contains the arguments, the execution start and stop times and per-file statistics of opens, reads, writes, starts and closes operations. --- config/runtime.cfg | 23 ++ libcob/Makefile.am | 2 +- libcob/coblocal.h | 4 + libcob/common.c | 14 +- libcob/common.h | 38 +++ libcob/fileio.c | 42 ++- libcob/jor.c | 464 +++++++++++++++++++++++++++ tests/testsuite.src/used_binaries.at | 2 + 8 files changed, 580 insertions(+), 9 deletions(-) create mode 100644 libcob/jor.c diff --git a/config/runtime.cfg b/config/runtime.cfg index 2111fc176..5f4b2aabf 100644 --- a/config/runtime.cfg +++ b/config/runtime.cfg @@ -217,6 +217,29 @@ # 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 diff --git a/libcob/Makefile.am b/libcob/Makefile.am index f3fb2343e..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 profiling.c + 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 9cc5e3b2e..f3013c51f 100644 --- a/libcob/coblocal.h +++ b/libcob/coblocal.h @@ -347,6 +347,9 @@ 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) */ @@ -448,6 +451,7 @@ 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]; diff --git a/libcob/common.c b/libcob/common.c index 0bf64f382..6a417d64d 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -505,6 +505,9 @@ 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)}, @@ -1113,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 @@ -1244,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); @@ -3050,6 +3056,7 @@ cob_stop_run (const int status) longjmp (return_jmp_buf, 1); } #endif + cob_jor_exit (status, "STOP RUN reached"); exit (status); } @@ -3104,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 */ @@ -3139,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 */ @@ -10352,6 +10363,7 @@ 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); diff --git a/libcob/common.h b/libcob/common.h index c87023951..d64d3dea5 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -1379,6 +1379,12 @@ typedef struct __cob_file_key { /* File version (likely can be removed from cob_file in the future) */ #define COB_FILE_VERSION 1 + +#define COB_JOR_FILE_OPERATIONS 10 +typedef struct __cob_file_jor { + cob_u32_t *ops [COB_JOR_FILE_OPERATIONS] ; +} cob_file_jor; + /* File structure */ /*NOTE: *** Add new fields to end *** @@ -1435,6 +1441,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; @@ -2864,6 +2871,37 @@ 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 */ +/************************/ + +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_AFTER_LAST_OPERATION +}; + +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 */ /************************/ 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..9f1c5c6ab --- /dev/null +++ b/libcob/jor.c @@ -0,0 +1,464 @@ +/* + 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 + +#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 + +/* 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 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_file_op[COB_JOR_FILE_OPERATIONS] ; + +static const char* field_file_op_name[COB_JOR_FILE_OPERATIONS] = { + "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: 8 bytes + * u32: total size of JOR (including the HEADER) + * u8: version (currently 1) + * u8[3]: 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 RECORD_BEGIN(opcode) { \ + char *jor_record_begin = jor_position; \ + jor_position += 2; \ + *jor_position++ = opcode +#define RECORD_END() \ + *((cob_u16_t*) jor_record_begin) = \ + jor_position - jor_record_begin; \ + *((cob_u32_t*) jor_buffer) = \ + jor_position - jor_buffer; \ + } +#define RECORD_FIELD(level,field,type) \ + *jor_position++ = level; \ + *jor_position++ = field; \ + *jor_position++ = type + +#define OPCODE_NEW_NAME 0 +#define OPCODE_LOCAL_FIELD 1 + +#define TYPE_RECORD 0 +#define TYPE_UINT8 1 +#define TYPE_INT8 2 +#define TYPE_UINT16 3 +#define TYPE_INT16 4 +#define TYPE_UINT32 5 +#define TYPE_INT32 6 +#define TYPE_UINT64 7 +#define TYPE_INT64 8 +#define TYPE_FLOAT 9 +#define TYPE_STRING8 10 +#define TYPE_STRING16 11 + +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); + * ( (cob_u32_t*)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, len, 1, fd); + fclose (fd); +} + +static struct cob_jor_funcs jor_funcs = { + jor_save, + jor_allocate +}; + +void cob_jor_set_funcs (struct cob_jor_funcs *f) +{ + jor_funcs.save = f->save; + jor_funcs.allocate = f->allocate; +} + +void cob_init_jor (cob_global *lptr, cob_settings *sptr, + int cob_argc, char** cob_argv) +{ + int i; + + if (!!cobsetptr) return ; + + 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 (COB_JOR_FILE_OPERATIONS != COB_JOR_AFTER_LAST_OPERATION){ + fprintf (stderr, "COB_JOR_FILE_OPERATIONS = %d\n", + COB_JOR_FILE_OPERATIONS); + fprintf (stderr, "COB_JOR_AFTER_LAST_OPERATION = %d\n", + COB_JOR_AFTER_LAST_OPERATION); + exit (2); + } + if ( field_file_op_name[COB_JOR_FILE_OPERATIONS-1] == NULL ){ + fprintf (stderr, + "field_file_op_name[%d] not initialized\n", + COB_JOR_FILE_OPERATIONS-1); + exit (2); + } + + if (!cobsetptr->cob_jor_enable && + /* testsuite clears COB_JOR_ENABLE... */ + !getenv ("COB_JOR_ENABLED")) return ; + + if (cob_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; + + jor_buffer +=4; /* size of journal */ + *jor_position = JOR_VERSION; /* version */ + jor_position += 3; /* 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"); + + /* 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 0; +} + +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)); + jor_field_record (0, field_file); + jor_field_string8 (1, field_name, + f->select_name); + } + + 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_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)++; + } +} + +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); + + 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_time); + jor_field_uint32 (2, field_secs, tv.tv_sec); + jor_field_uint32 (2, field_usecs, tv.tv_usec); + + 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/tests/testsuite.src/used_binaries.at b/tests/testsuite.src/used_binaries.at index f97f81468..b570cafac 100644 --- a/tests/testsuite.src/used_binaries.at +++ b/tests/testsuite.src/used_binaries.at @@ -1117,6 +1117,8 @@ 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. From 8298eea860f06335d5cc1f27ff7a3c51decfaf2e Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Thu, 28 Mar 2024 13:10:03 +0100 Subject: [PATCH 3/3] Add bin/jorread to translate JOR files to JSON --- bin/Makefile.am | 6 +- bin/jorread.c | 254 ++++++++++++++++++++++++++++++++++++++++++++++++ libcob/common.h | 52 +++++++--- libcob/jor.c | 139 ++++++++++++++++---------- 4 files changed, 382 insertions(+), 69 deletions(-) create mode 100644 bin/jorread.c 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 +#include /* Remember static and dynamic configuration */ static cob_global *cobglobptr = NULL; @@ -62,6 +63,7 @@ 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 ; @@ -75,10 +77,11 @@ 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_FILE_OPERATIONS] ; +static int field_file_op[COB_JOR_OPERATIONS_MAX] ; -static const char* field_file_op_name[COB_JOR_FILE_OPERATIONS] = { +static const char* field_file_op_name[COB_JOR_OPERATIONS_MAX] = { "write-try", "write-ok", "read-try", @@ -99,10 +102,12 @@ static const char* field_file_op_name[COB_JOR_FILE_OPERATIONS] = { * 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: 8 bytes + HEADER: 16 bytes + * u8[8]: magic = GNUCOJOR" * u32: total size of JOR (including the HEADER) * u8: version (currently 1) - * u8[3]: padding (not used) + * u8: byte order (little-endian = 0, big-endian = 1) + * u8[2]: padding (not used) JOURNAL: a concatenation of records @@ -195,37 +200,28 @@ exit = { */ +#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() \ - *((cob_u16_t*) jor_record_begin) = \ - jor_position - jor_record_begin; \ - *((cob_u32_t*) jor_buffer) = \ - jor_position - jor_buffer; \ + 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 -#define OPCODE_NEW_NAME 0 -#define OPCODE_LOCAL_FIELD 1 - -#define TYPE_RECORD 0 -#define TYPE_UINT8 1 -#define TYPE_INT8 2 -#define TYPE_UINT16 3 -#define TYPE_INT16 4 -#define TYPE_UINT32 5 -#define TYPE_INT32 6 -#define TYPE_UINT64 7 -#define TYPE_INT64 8 -#define TYPE_FLOAT 9 -#define TYPE_STRING8 10 -#define TYPE_STRING16 11 - static int jor_field_name (const char* s) { int id = jor_name_counter++; @@ -257,7 +253,7 @@ static void jor_field_uint32 (int level, int field, cob_u32_t v) { RECORD_BEGIN (OPCODE_LOCAL_FIELD); RECORD_FIELD (level, field, TYPE_UINT32); - * ( (cob_u32_t*)jor_position) = v; + SET_U32 (jor_position, v); jor_position += 4; RECORD_END (); } @@ -285,7 +281,7 @@ void jor_save (const char* filename, char* buffer, int len) { FILE *fd = fopen (filename, "w"); const char* s = jor_buffer; - fwrite (s, len, 1, fd); + fwrite (s, 1, len, fd); fclose (fd); } @@ -294,36 +290,43 @@ static struct cob_jor_funcs jor_funcs = { 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) { - jor_funcs.save = f->save; - jor_funcs.allocate = f->allocate; + 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 cob_argc, char** cob_argv) + int argc, char** argv) { int i; - if (!!cobsetptr) return ; - 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 (COB_JOR_FILE_OPERATIONS != COB_JOR_AFTER_LAST_OPERATION){ - fprintf (stderr, "COB_JOR_FILE_OPERATIONS = %d\n", - COB_JOR_FILE_OPERATIONS); - fprintf (stderr, "COB_JOR_AFTER_LAST_OPERATION = %d\n", - COB_JOR_AFTER_LAST_OPERATION); - exit (2); - } - if ( field_file_op_name[COB_JOR_FILE_OPERATIONS-1] == NULL ){ + if ( field_file_op_name[COB_JOR_OPERATIONS_MAX-1] == NULL ){ fprintf (stderr, "field_file_op_name[%d] not initialized\n", - COB_JOR_FILE_OPERATIONS-1); + COB_JOR_OPERATIONS_MAX-1); exit (2); } @@ -331,7 +334,7 @@ void cob_init_jor (cob_global *lptr, cob_settings *sptr, /* testsuite clears COB_JOR_ENABLE... */ !getenv ("COB_JOR_ENABLED")) return ; - if (cob_argc == 0) return ; + if (argc == 0) return ; is_active = 1; @@ -342,9 +345,16 @@ void cob_init_jor (cob_global *lptr, cob_settings *sptr, jor_size = cobsetptr->cob_jor_max_size ; jor_position = jor_buffer; - jor_buffer +=4; /* size of journal */ - *jor_position = JOR_VERSION; /* version */ - jor_position += 3; /* padding */ + 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"); @@ -358,6 +368,7 @@ void cob_init_jor (cob_global *lptr, cob_settings *sptr, 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); @@ -366,12 +377,17 @@ void cob_init_jor (cob_global *lptr, cob_settings *sptr, 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; ijor){ 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]; @@ -414,6 +440,7 @@ void cob_jor_file_operation (cob_file *f, enum cob_jor_file_operation op) } 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 ; @@ -423,6 +450,12 @@ void cob_jor_file_operation (cob_file *f, enum cob_jor_file_operation op) } } +/* +\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){ @@ -441,6 +474,10 @@ void cob_jor_exit(int code, const char* fmt, ...) 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--; @@ -448,10 +485,6 @@ void cob_jor_exit(int code, const char* fmt, ...) tv.tv_usec -= tv0.tv_usec; tv.tv_sec -= tv0.tv_sec; - jor_field_record (1, field_time); - jor_field_uint32 (2, field_secs, tv.tv_sec); - jor_field_uint32 (2, field_usecs, tv.tv_usec); - jor_field_record (1, field_duration); jor_field_uint32 (2, field_secs, tv.tv_sec); jor_field_uint32 (2, field_usecs, tv.tv_usec);