From: Robert Dubner <[email protected]>
Date: Mon, 1 Jun 2026 22:50:28 -0400
Subject: [PATCH] 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.
---
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 a3d6ff37c4c..3fade5813d3 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 d20ac94c32d..d966c58f7b3 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 7bda84d85a4..ecc37031a00 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 c93673815f1..283864c85cc 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 c81429fc36e..dce815acc85 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;
+ }
+
--
2.34.1
