https://gcc.gnu.org/g:98a4ce5b801def164c491032ca30a3fc7839847b
commit r17-1154-g98a4ce5b801def164c491032ca30a3fc7839847b Author: Robert Dubner <[email protected]> Date: Mon Jun 1 22:50:28 2026 -0400 cobol: Improve execution speed of FUNCTION TRIM. By breaking out specific code for FUNCTION TRIM when the string is single-byte-coded ASCII or EBCDIC, and by creating a matching __gg__trim_1 routine using std::find_if(), the function operates about fifteen to 25 times faster than it did. gcc/cobol/ChangeLog: * compare.cc (cobol_compare_relop): Rename the cobol_compare_relop function. (cobol_compare): Likewise. * compare.h (cobol_compare_relop): Likewise. (cobol_compare): Likewise. * genapi.cc (parser_display): Refine the use of SYSPUNCH_e for inserting debugging comments into the assembly language. (parser_relop): Use "cobol_compare". (handle_gg_trim): Break out SBC TRIM logic. (parser_intrinsic_call_2): Likewise. (parser_bsearch_when): Use "cobol_compare" * genutil.cc (refer_is_super_clean): FldLiteralN is always "super clean". (is_pure_integer): Make binary_from_FldNumericBin5 "static bool". (binary_from_FldLiteralN): New function. (get_binary_value): Use the new function. libgcobol/ChangeLog: * intrinsic.cc (__gg__trim): Eliminate useless comment. (__gg__trim_1): New function. Diff: --- gcc/cobol/compare.cc | 8 ++--- gcc/cobol/compare.h | 8 ++--- gcc/cobol/genapi.cc | 84 +++++++++++++++++++++++++++++++++++++++++--------- gcc/cobol/genutil.cc | 45 +++++++++++++++++++++------ libgcobol/intrinsic.cc | 55 ++++++++++++++++++++++++++++++++- 5 files changed, 167 insertions(+), 33 deletions(-) diff --git a/gcc/cobol/compare.cc b/gcc/cobol/compare.cc index a3d6ff37c4c8..3fade5813d37 100644 --- a/gcc/cobol/compare.cc +++ b/gcc/cobol/compare.cc @@ -1368,10 +1368,10 @@ compare_class( tree &left, } void -cobol_compare_relop(tree &left, - tree &right, - const cbl_refer_t &left_side, - const cbl_refer_t &right_side) +cobol_compare(tree &left, + tree &right, + const cbl_refer_t &left_side, + const cbl_refer_t &right_side) { // This routine figures out how to compare left_side to right_side, and // returns the trees 'left' and 'right' in numeric form that can be turned diff --git a/gcc/cobol/compare.h b/gcc/cobol/compare.h index d20ac94c32d4..d966c58f7b34 100644 --- a/gcc/cobol/compare.h +++ b/gcc/cobol/compare.h @@ -34,9 +34,9 @@ "left" and "right" var_decl trees, which can be fed directly into one of the six relational expressions like EQ_EXPR, LT_EXPR, and so on. */ -void cobol_compare_relop( tree &left, - tree &right, - const cbl_refer_t &left_side, - const cbl_refer_t &right_side); +void cobol_compare( tree &left, + tree &right, + const cbl_refer_t &left_side, + const cbl_refer_t &right_side); #endif diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 7bda84d85a4e..ecc37031a00f 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -5254,7 +5254,6 @@ parser_display( const struct cbl_special_name_t *upon, case SYSOUT_e: case SYSLIST_e: case SYSLST_e: - case SYSPUNCH_e: case SYSPCH_e: // In the 21st century, when there are no longer valid assumptions to // be made about the existence of line printers, and where things @@ -5269,6 +5268,22 @@ parser_display( const struct cbl_special_name_t *upon, needs_closing = true; break; + case SYSPUNCH_e: + // With the ASSEMBLER environment variable, SYSPUNCH means "insert + // the text into the assembly language". So, we don't need a file + // descriptor. + if( !getenv("ASSEMBLER") ) + { + gg_assign(file_descriptor, + gg_call_expr( INT, + "__gg__get_file_descriptor", + gg_string_literal(upon->os_filename), + NULL_TREE)); + needs_closing = true; + } + break; + + case ARG_NUM_e: // Set the index number for a subsequent ACCEPT FROM ARG_VALUE_e gg_call(VOID, @@ -7736,7 +7751,7 @@ parser_relop( cbl_field_t *tgt, tree left; tree right; - cobol_compare_relop(left, right, aref, bref); + cobol_compare(left, right, aref, bref); tgt->var_decl_node = gg_build_relational_expression(left, relop, right); @@ -11377,6 +11392,38 @@ parser_intrinsic_call_1( cbl_field_t *tgt, } } +static bool +handle_gg_trim(cbl_field_t *tgt, + const char function_name[], + const cbl_refer_t& ref1, + const cbl_refer_t& ref2 ) + { + bool handled = false; + if( strcmp(function_name, "__gg__trim") == 0 ) + { + charmap_t *charmap = __gg__get_charmap(ref1.field->codeset.encoding); + if(charmap->stride() == 1) + { + uint8_t space = charmap->mapped_character(ascii_space); + int how = atoi(ref2.field->data.original()); + if( how == 0 ) + { + how = 3; + } + gg_call(VOID, + "__gg__trim_1", + gg_get_address_of(tgt->var_decl_node), + gg_get_address_of(ref1.field->var_decl_node), + refer_offset(ref1), + refer_size_source(ref1), + build_int_cst_type(INT, (space<<8) + how), + NULL_TREE); + handled = true; + } + } + return handled; + } + void parser_intrinsic_call_2( cbl_field_t *tgt, const char function_name[], @@ -11404,17 +11451,24 @@ parser_intrinsic_call_2( cbl_field_t *tgt, } store_location_stuff(function_name); - gg_call(VOID, - function_name, - gg_get_address_of(tgt->var_decl_node), - gg_get_address_of(ref1.field->var_decl_node), - refer_offset(ref1), - refer_size_source(ref1), - ref2.field ? gg_get_address_of(ref2.field->var_decl_node) - : null_pointer_node, - refer_offset(ref2), - refer_size_source(ref2), - NULL_TREE); + if( handle_gg_trim(tgt, function_name, ref1, ref2) ) + { + // The specialty routine did the job + } + else + { + gg_call(VOID, + function_name, + gg_get_address_of(tgt->var_decl_node), + gg_get_address_of(ref1.field->var_decl_node), + refer_offset(ref1), + refer_size_source(ref1), + ref2.field ? gg_get_address_of(ref2.field->var_decl_node) + : null_pointer_node, + refer_offset(ref2), + refer_size_source(ref2), + NULL_TREE); + } TRACE1 { TRACE1_INDENT @@ -12010,11 +12064,11 @@ parser_bsearch_when(cbl_label_t* name, tree right; if( ascending ) { - cobol_compare_relop(left, right, key, sarg); + cobol_compare(left, right, key, sarg); } else { - cobol_compare_relop(left, right, sarg, key); + cobol_compare(left, right, sarg, key); } IF( left, lt_op, right ) diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc index c93673815f1b..283864c85cc3 100644 --- a/gcc/cobol/genutil.cc +++ b/gcc/cobol/genutil.cc @@ -2024,13 +2024,19 @@ refer_is_super_clean(const cbl_refer_t &refer) // otherwise in condition so that we can use refer.field->var_data_node for // GENERIC, thus getting rid the additional level of indirection through // the refer.field->var_decl_node::data pointer - return refer_is_clean(refer) - && !(refer.field->attr & ( based_e - | linkage_e - | local_e - | intermediate_e - | any_length_e - | external_e)) ; + + // Note: By rights, FldLiteralA should be super-clean, but errors ensue when + // it is made so. This should be tracked down. The disconnect might be in + // get_location(). + return // refer.field->type == FldLiteralA || + refer.field->type == FldLiteralN + || (refer_is_clean(refer) + && !(refer.field->attr & ( based_e + | linkage_e + | local_e + | intermediate_e + | any_length_e + | external_e))) ; } bool @@ -2316,7 +2322,7 @@ is_pure_integer(const cbl_field_t *field) return retval; } -bool +static bool binary_from_FldNumericBin5(tree &value, const cbl_refer_t &refer, tree type) { bool retval = false; @@ -2403,6 +2409,24 @@ binary_from_FldNumericBin5(tree &value, const cbl_refer_t &refer, tree type) return retval; } +static bool +binary_from_FldLiteralN(tree &value, const cbl_refer_t &refer, tree type) + { + // The data_decl_node has the value we need. + + tree source_type = tree_type_from_field(refer.field); + if( !type ) + { + type = source_type; + } + + value = gg_define_variable(type); + gg_assign(value, gg_cast(type, refer.field->data_decl_node)); + + return true; + } + + bool binary_from_FldNumericBinary(tree &value, const cbl_refer_t &refer, tree type) { @@ -3116,8 +3140,11 @@ get_binary_value(tree &value, const cbl_refer_t &refer, tree type) // We know that the refer is a type that involves an integer binary value. switch(refer.field->type) { - case FldNumericBin5: case FldLiteralN: + retval = binary_from_FldLiteralN(value, refer, type); + break; + + case FldNumericBin5: case FldIndex: case FldPointer: retval = binary_from_FldNumericBin5(value, refer, type); diff --git a/libgcobol/intrinsic.cc b/libgcobol/intrinsic.cc index c81429fc36e1..dce815acc855 100644 --- a/libgcobol/intrinsic.cc +++ b/libgcobol/intrinsic.cc @@ -3530,7 +3530,6 @@ __gg__trim( cblc_field_t *dest, arg2, arg2_offset, arg2_size); - //static const int BOTH = 0; #define LEADING 1 // Remove leading spaces #define TRAILING 2 // Remove trailing spaces @@ -5840,3 +5839,57 @@ __gg__locale_time_from_seconds( cblc_field_t *dest, __gg__field_from_string(dest, 0, dest->capacity, converted, bytes_converted); free(converted); } + + +extern "C" +void +__gg__trim_1( cblc_field_t *dest, + const cblc_field_t *src, + size_t src_offset, + size_t src_size, + int space_how ) // (space<<8) + how + { + // This is the no-holds-barred, do-it-as-fast-as-possible, TRIM routine. It + // gets called only when the stride is 1. Spaces is eight bytes of the + // character to be trimmed away, usually 0x2020202020202020 because we are + // usually working in ASCII. 'how' indicates LEADING and TRAILING. + + #define LEADING 1 // Remove leading spaces + #define TRAILING 2 // Remove trailing spaces + + const uint8_t *left = src->data + src_offset; // Leftmost character + const uint8_t *right = left + src_size; // One past the end + + uint8_t space = space_how >> 8; + + if ((space_how & LEADING) && left < right) + { + left = std::find_if(left, right, [space](uint8_t c) + { + return c != space; + }); + } + + if( (space_how & TRAILING) && left < right) + { + right = std::find_if( + std::make_reverse_iterator(right), + std::make_reverse_iterator(left), + [space](uint8_t c) { return c != space; } + ).base(); + } + + size_t bytes_converted = right - left; + __gg__adjust_dest_size(dest, bytes_converted); + +#if 0 + __gg__field_from_string(dest, 0, dest->capacity, reinterpret_cast<const char *>(left), bytes_converted); +#else + memcpy(dest->data, + left, + bytes_converted); +#endif + + return; + } +
