https://gcc.gnu.org/g:386d81e74305e7f19323d4438f54b9abffa82795
commit r17-4662-g386d81e74305e7f19323d4438f54b9abffa82795 Author: Robert Dubner <[email protected]> Date: Fri Sep 25 12:35:03 2026 -0400 cobol: Reduce middle-end time with better GENERIC. These changes reduce compilation time for -fno-static-call CALL <literal> COBOL statements by consolidating several calls to libgcobol into one call. Another change improved compilation speed slightly by placing several parameters for a library call into a structure. The address of that structure is passed, rather than passing the individual parameters. The processing of the -fstatic-call and the -fno-static-call options is fixed; until now, using either resulting in no-static-call behavior. gcc/cobol/ChangeLog: * cobol1.cc (use_static_call): Change name of global function to set_use_static_call. (set_use_static_call): Likewise. (cobol_langhook_handle_option): Use 'value' parameter rather than 'arg' parameter. * genapi.cc (use_static_call): Change name. (set_use_static_call): Likewise. (create_and_call): Call push/pop_program_state in the correct order. (literal_call_descriptor_type): Use common structure definition in both compile-time and run-time code. (GCOBOL_CALL_FIELD_NAME): Likewise. (GCOBOL_CALL_FIELD_TYPE): Likewise. (literal_call_descriptor): Likewise. (GCOBOL_CALL_FIELD_VALUE): Likewise. (function_pointer_for_literal_call): Consolidate several calls to libgcobol. (parser_call): Likewise. * lang.opt: Modify definition of -fstatic-call. libgcobol/ChangeLog: * libgcobol.cc (__gg__call_warning_message): Moved here from compile time. (__gg__resolve_literal_call): New consolidated function. * literal-call-descriptor.h: New file. Diff: --- gcc/cobol/cobol1.cc | 4 +- gcc/cobol/genapi.cc | 218 ++++++++++++++++++++++++++++-------- gcc/cobol/lang.opt | 2 +- libgcobol/libgcobol.cc | 65 +++++++++++ libgcobol/literal-call-descriptor.h | 31 +++++ 5 files changed, 273 insertions(+), 47 deletions(-) diff --git a/gcc/cobol/cobol1.cc b/gcc/cobol/cobol1.cc index 4cc024c8b0f1..354c568347be 100644 --- a/gcc/cobol/cobol1.cc +++ b/gcc/cobol/cobol1.cc @@ -344,7 +344,7 @@ cobol_option_lang_mask (void) { return CL_Cobol; } -bool use_static_call( bool yn ); +bool set_use_static_call( bool yn ); void add_cobol_exception( ec_type_t type, bool ); bool include_file_add(const char input[]); @@ -517,7 +517,7 @@ cobol_langhook_handle_option (size_t scode, return true; case OPT_fstatic_call: - use_static_call( arg? true : false ); + set_use_static_call( value != 0 ); return true; case OPT_fdefaultbyte: diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 301fd6f82e26..62a8ea918db3 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -32,6 +32,10 @@ #include "coretypes.h" #include "tree.h" +#include "stor-layout.h" +#include "ggc.h" +#include "gtype-desc.h" +#include "../../libgcobol/literal-call-descriptor.h" #include "tree-iterator.h" #include "stringpool.h" #include "diagnostic-core.h" @@ -155,7 +159,7 @@ static bool next_program_is_main = false; // transient switch for the module static char *main_entry_point = NULL; static bool static_call = true; -bool use_static_call( bool yn ) { return static_call = yn; } +bool set_use_static_call( bool yn ) { return static_call = yn; } static bool use_static_call() { return static_call; } // This global variable can be set upstream, like from a compiler @@ -13034,8 +13038,9 @@ create_and_call(size_t narg, // Actually call the function, assigning the returned value to that // variable: + returned_value = gg_define_variable(interfunction_type); push_program_state(); - returned_value = call_expr; + gg_assign(returned_value, call_expr); pop_program_state(); // Now we decided what to do with the returned value, based on its type. @@ -13145,6 +13150,133 @@ create_and_call(size_t narg, } } +/* Cache one target-layout type and keep it reachable across GCC collections. + Dynamic root registration avoids requiring a new gengtype input file. */ +static tree literal_call_descriptor_type_node; + +static const struct ggc_root_tab literal_call_descriptor_roots[] = + { + { &literal_call_descriptor_type_node, 1, sizeof(tree), + >_ggc_mx_tree_node, >_pch_nx_tree_node }, + LAST_GGC_ROOT_TAB + }; + +static tree +literal_call_descriptor_type() + { + if( literal_call_descriptor_type_node != NULL_TREE ) + { + return literal_call_descriptor_type_node; + } + + ggc_register_root_tab(literal_call_descriptor_roots); + tree record = make_node(RECORD_TYPE); + literal_call_descriptor_type_node = record; + TYPE_NAME(record) = get_identifier("cblc_literal_call_descriptor"); + + tree const_char_pointer + = build_pointer_type(build_qualified_type(char_type_node, TYPE_QUAL_CONST)); + tree const_void_pointer + = build_pointer_type(build_qualified_type(void_type_node, TYPE_QUAL_CONST)); + +#define GCOBOL_CALL_FIELD_NAME(name, c_type, tree_type) #name, + const char *names[] = + { + GCOBOL_LITERAL_CALL_DESCRIPTOR_FIELDS(GCOBOL_CALL_FIELD_NAME) + }; +#undef GCOBOL_CALL_FIELD_NAME +#define GCOBOL_CALL_FIELD_TYPE(name, c_type, tree_type) tree_type, + tree types[] = + { + GCOBOL_LITERAL_CALL_DESCRIPTOR_FIELDS(GCOBOL_CALL_FIELD_TYPE) + }; +#undef GCOBOL_CALL_FIELD_TYPE + + tree *next = &TYPE_FIELDS(record); + for( size_t i = 0; i < sizeof(types) / sizeof(types[0]); i++ ) + { + tree member_decl = build_decl(UNKNOWN_LOCATION, + FIELD_DECL, + get_identifier(names[i]), + types[i]); + DECL_FIELD_CONTEXT(member_decl) = record; + *next = member_decl; + next = &DECL_CHAIN(member_decl); + } + *next = NULL_TREE; + layout_type(record); + return record; + } + +/* Emit a static initializer, not executable per-call assignments. */ +static tree +literal_call_descriptor(const cbl_refer_t &name, bool issue_warning) + { + tree record = literal_call_descriptor_type(); + tree literal = gg_string_literal(name.field->data.original()); + tree field = gg_get_address_of(name.field->var_decl_node); + tree warning_filename = null_pointer_node; + tree program_id + = build_int_cst(INT, current_function->our_symbol_table_index); + tree call_convention = build_int_cst_type(INT, current_call_convention()); + tree warning_line = integer_zero_node; + + if( issue_warning ) + { + warning_filename = gg_string_literal(current_filename.back().c_str()); + warning_line = build_int_cst_type(INT, CURRENT_LINE_NUMBER); + } + +#define GCOBOL_CALL_FIELD_VALUE(name, c_type, tree_type) name, + tree values[] = + { + GCOBOL_LITERAL_CALL_DESCRIPTOR_FIELDS(GCOBOL_CALL_FIELD_VALUE) + }; +#undef GCOBOL_CALL_FIELD_VALUE + + vec<constructor_elt, va_gc> *elts = NULL; + tree member_decl = TYPE_FIELDS(record); + for( size_t i = 0; i < sizeof(values) / sizeof(values[0]); i++ ) + { + tree value = gg_cast(TREE_TYPE(member_decl), values[i]); + CONSTRUCTOR_APPEND_ELT(elts, member_decl, value); + member_decl = DECL_CHAIN(member_decl); + } + gcc_assert(member_decl == NULL_TREE); + + tree initializer = build_constructor(record, elts); + gcc_assert(TREE_CONSTANT(initializer)); + TREE_STATIC(initializer) = 1; + + // vs_static supplies a unique name and roots the declaration in its function. + tree descriptor = gg_define_variable(record, vs_static); + TREE_READONLY(descriptor) = 1; + DECL_ARTIFICIAL(descriptor) = 1; + DECL_IGNORED_P(descriptor) = 1; + DECL_INITIAL(descriptor) = initializer; + return gg_get_address_of(descriptor); + } + +static tree +function_pointer_for_literal_call(const cbl_refer_t &name, + tree function_return_type, + bool issue_warning) + { + tree function_type = build_varargs_function_type_array( + function_return_type, + 0, + NULL); + tree function_pointer_type = build_pointer_type(function_type); + tree descriptor = literal_call_descriptor(name, issue_warning); + + return gg_cast( + function_pointer_type, + gg_call_expr(VOID_P, + "__gg__resolve_literal_call_descriptor", + descriptor, + NULL_TREE)); + } + void parser_call( cbl_refer_t name, cbl_refer_t returned, // This is set by RETURNING clause @@ -13154,9 +13286,6 @@ parser_call( cbl_refer_t name, cbl_label_t *not_except, bool /*is_function*/) { - // A note on the processing of function return types: - - Analyze(); SHOW_PARSE { @@ -13266,9 +13395,23 @@ parser_call( cbl_refer_t name, } else { - tree function_pointer = function_pointer_from_name( name, - interfunction_type); - // We might not have a good handle, so we have to check: + const bool literal_call = name.field->type == FldLiteralA; + const bool issue_warning + = !except && !cdf_enabled_exceptions().match(ec_program_not_found_e); + + tree function_pointer; + if( literal_call ) + { + function_pointer = function_pointer_for_literal_call(name, + interfunction_type, + issue_warning); + } + else + { + function_pointer = function_pointer_from_name(name, interfunction_type); + } + function_pointer = save_expr(function_pointer); + IF( function_pointer, ne_op, gg_cast(TREE_TYPE(function_pointer), null_pointer_node) ) @@ -13283,47 +13426,34 @@ parser_call( cbl_refer_t name, } ELSE { - // We have a bad function pointer, which is the exception condition: - // Set the exception message to "name" - gg_call(VOID, - "__gg__set_exception_call", - gg_get_address_of(name.field->var_decl_node), - refer_offset(name), - NULL_TREE); - parser_exception_raise(ec_program_not_found_e); + /* The literal resolver has already recorded lookup failure. + Variable-name calls retain their existing bookkeeping. */ + if( !literal_call ) + { + gg_call(VOID, + "__gg__set_exception_call", + gg_get_address_of(name.field->var_decl_node), + refer_offset(name), + NULL_TREE); + parser_exception_raise(ec_program_not_found_e); + } + if( except ) { - // We have an ON EXCEPT clause: - gg_append_statement( except->structs.call_exception->into.go_to ); - // Because there is an ON EXCEPTION clause, suppress DECLARATIVE - // processing + // Preserve the existing ON EXCEPTION routing and reset placement. + gg_append_statement(except->structs.call_exception->into.go_to); gg_assign(var_decl_exception_code, integer_zero_node); } - else + else if( !literal_call && issue_warning ) { - // When EC-PROGRAM-NOT-FOUND is not enabled, we issue a warning. - const cbl_enabled_exceptions_t& - enabled_exceptions( cdf_enabled_exceptions() ); - if( !enabled_exceptions.match(ec_program_not_found_e) ) - { - tree mangled_name = gg_define_variable(CHAR_P); - - gg_call(VOID, - "__gg__just_mangle_name", - (name.field->var_decl_node - ? gg_get_address_of(name.field->var_decl_node) - : null_pointer_node), - gg_get_address_of( mangled_name), - NULL_TREE); - - gg_printf("WARNING: %s:%d \"CALL %s\" not found" - " with no \"CALL ON EXCEPTION\" phrase.\n" - "(You might need -rdynamic or --export-dynamic for symbols in the executable.)\n", - gg_string_literal(current_filename.back().c_str()), - build_int_cst_type(INT, CURRENT_LINE_NUMBER), - mangled_name, - NULL_TREE); - } + gg_call(VOID, + "__gg__call_warning_message", + (name.field->var_decl_node + ? gg_get_address_of(name.field->var_decl_node) + : null_pointer_node), + gg_string_literal(current_filename.back().c_str()), + build_int_cst_type(INT, CURRENT_LINE_NUMBER), + NULL_TREE); } } ENDIF diff --git a/gcc/cobol/lang.opt b/gcc/cobol/lang.opt index 0d381a3394e3..32553775c0e7 100644 --- a/gcc/cobol/lang.opt +++ b/gcc/cobol/lang.opt @@ -436,7 +436,7 @@ Cobol RejectNegative Joined Separate UInteger Var(indicator_column) Init(0) Inte -findicator-column=<n> Column after which Region A begins. fstatic-call -Cobol Var(cobol_static_call, 1) Init(1) +Cobol Var(cobol_static_call) Init(1) Enable/disable static linkage for CALL literals. ftrace-debug diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc index 7e48914c8e52..f4bb4c18e702 100644 --- a/libgcobol/libgcobol.cc +++ b/libgcobol/libgcobol.cc @@ -67,6 +67,7 @@ #include "gcobolio.h" #include "cobol-endian.h" #include "libgcobol.h" +#include "literal-call-descriptor.h" #include "gfileio.h" #include "charmaps.h" #include "valconv.h" @@ -11288,6 +11289,25 @@ __gg__just_mangle_name( const cblc_field_t *field, } } +extern "C" +void +__gg__call_warning_message(const cblc_field_t *name, + const char *filename, + int line_number) + { + char *mangled_name = nullptr; + __gg__just_mangle_name(name, &mangled_name); + + fprintf(stderr, + "WARNING: %s:%d \"CALL %s\" not found" + " with no \"CALL ON EXCEPTION\" phrase.\n" + "(You might need -rdynamic or --export-dynamic for symbols" + " in the executable.)\n", + filename, + line_number, + mangled_name); + } + extern "C" void * __gg__function_handle_from_literal(int program_id, @@ -13697,6 +13717,51 @@ __gg__set_exception_call(const cblc_field_t *field, &nbytes); } +/* A null warning_filename suppresses the warning, not exception bookkeeping. + This wrapper is only for literal CALL statements; other resolver users + retain the original resolver interface without CALL exception bookkeeping. */ +extern "C" +void * +__gg__resolve_literal_call(int program_id, + const char *literal, + int call_convention, + const cblc_field_t *field, + const char *warning_filename, + int warning_line) + { + void *target = __gg__function_handle_from_literal(program_id, + literal, + call_convention); + + if( target == nullptr ) + { + __gg__set_exception_call(field, 0); + __gg__set_exception_code(ec_program_not_found_e, 1); + + if( warning_filename != nullptr ) + { + __gg__call_warning_message(field, warning_filename, warning_line); + } + } + + return target; + } + +/* Keep the six-argument entry point available for existing generated code. */ +extern "C" +void * +__gg__resolve_literal_call_descriptor( + const cblc_literal_call_descriptor *descriptor) + { + return __gg__resolve_literal_call( + descriptor->program_id, + descriptor->literal, + descriptor->call_convention, + static_cast<const cblc_field_t *>(descriptor->field), + descriptor->warning_filename, + descriptor->warning_line); + } + extern "C" int __gg__prohibited(const cblc_field_t *field, __int128 value) diff --git a/libgcobol/literal-call-descriptor.h b/libgcobol/literal-call-descriptor.h new file mode 100644 index 000000000000..57db43ba12aa --- /dev/null +++ b/libgcobol/literal-call-descriptor.h @@ -0,0 +1,31 @@ +/* Shared layout for compiler-generated literal CALL descriptors. + Field order and C/GCC type mappings are defined together here. */ +#ifndef GCOBOL_LITERAL_CALL_DESCRIPTOR_H +#define GCOBOL_LITERAL_CALL_DESCRIPTOR_H + +/* X(member name, runtime C++ type, compiler target tree type). + The third argument is only expanded by the GENERIC builder. */ +#define GCOBOL_LITERAL_CALL_DESCRIPTOR_FIELDS(X) \ + X(literal, const char *, const_char_pointer) \ + X(field, const void *, const_void_pointer) \ + X(warning_filename, const char *, const_char_pointer) \ + X(program_id, int, INT) \ + X(call_convention, int, INT) \ + X(warning_line, int, INT) + +struct cblc_literal_call_descriptor + { +#define GCOBOL_DECLARE_CALL_FIELD(name, c_type, tree_type) c_type name; + GCOBOL_LITERAL_CALL_DESCRIPTOR_FIELDS(GCOBOL_DECLARE_CALL_FIELD) +#undef GCOBOL_DECLARE_CALL_FIELD + }; + +/* literal and warning_filename use the existing NUL-terminated resolver + and diagnostic interfaces. field points to a counted cblc_field_t. + A null warning_filename suppresses the warning only. + The descriptor contains metadata, never a cached resolved address. */ +extern "C" void * +__gg__resolve_literal_call_descriptor( + const cblc_literal_call_descriptor *descriptor); + +#endif
