From: Robert Dubner <[email protected]>
Date: Fri, 25 Sep 2026 12:35:03 -0400
Subject: [PATCH] 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.
---
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(-)
create mode 100644 libgcobol/literal-call-descriptor.h
diff --git a/gcc/cobol/cobol1.cc b/gcc/cobol/cobol1.cc
index 4cc024c8b0f..354c568347b 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 301fd6f82e2..62a8ea918db 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 0d381a3394e..32553775c0e 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 7e48914c8e5..f4bb4c18e70 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 00000000000..57db43ba12a
--- /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
--
2.34.1
