From 2dbcef486026e7aa919283e57f8cc8340a3f22b6 Mon Sep 17 00:00:00 2001
From: Robert Dubner <rdubner@symas.com>
Date: Wed, 2 Sep 2026 00:46:54 -0400
Subject: [PATCH] cobol: Normalize call/return value types; improve
execution speed.
My recent efforts to improve middle-end processing time by radically
reducing the number of VAR_DECLs I created led to subtle problems that
showed up as signed/unsigned assignment mismatches in gimple processing.
This patch includes changes that are more rigorous about both passing
values to a called routine, and processing values from a called routine.
This patch also makes changes to the stringbin.cc module that speed up
conversions between binary values and various COBOL variable memory
representations.
gcc/cobol/ChangeLog:
* genapi.cc (program_end_stuff): Eliminate VAR_DECL, use
save_expr()
instead. Use proper type conversion.
(create_and_call): Likewise.
(parser_call): Use proper type conversion.
* move.cc (mh_source_is_literalN): Eliminate a VAR_DECL.
(copy_native_into_place): Likewise.
libgcobol/ChangeLog:
* stringbin.cc (uint_to_8_digits): Fix static variable error.
Improve speed.
(uint_to_8_digits_direct): New faster routine.
(string_from_combined): Eliminated.
(string_from_uint64): New faster routine.
(binary_to_string): Improved speed.
(__gg__binary_to_string_ascii): Fix static variable error.
(__gg__binary_to_string_ebcdic): Likewise.
(__gg__binary_to_string_encoded): Improved speed.
(uint32_to_packed): New faster routine.
(uint64_to_packed): Likewise.
(packed_from_combined): Eliminated.
(moderate_uint128_to_packed): New faster routine.
(large_uint128_to_packed): Likewise.
(__gg__binary_to_packed): Improved speed.
(pd_dive_rt): Eliminated.
(four_packed_bytes_to_uint32): New faster routine.
(initial_packed_bytes_to_uint32): Likewise.
(packed_bytes_to_uint64): Likewise.
(packed_bytes_to_uint128): Likewise.
(__gg__packed_to_binary): Use faster routines.
gcc/testsuite/ChangeLog:
* cobol.dg/group2/CURRENCY_SIGN_WITH_PICTURE_SYMBOL.cob:
Syntax error handling.
* cobol.dg/group2/FUNCTION_as_CALL_parameter_BY_CONTENT.cob:
Likewise.
* cobol.dg/group2/Simple_COMP-X.cob: Different handling of large
COMP-X values.
* cobol.dg/group2/Simple_COMP-X.out: Likewise.
*
cobol.dg/group2/Ignore_1970s_segment_numbers_for_segmenting_programs.cob:
New test.
*
cobol.dg/group2/Ignore_1970s_segment_numbers_for_segmenting_programs.out:
New test.
* cobol.dg/group2/PR59_RT3586_-_Code_format_heuristic_fails.cob:
New test.
* cobol.dg/group2/RT3609_Unexpected_PROCESS.cob: New test.
---
gcc/cobol/genapi.cc | 47 +-
gcc/cobol/move.cc | 31 +-
.../CURRENCY_SIGN_WITH_PICTURE_SYMBOL.cob | 7 +-
.../FUNCTION_as_CALL_parameter_BY_CONTENT.cob | 2 +-
...egment_numbers_for_segmenting_programs.cob | 18 +
...egment_numbers_for_segmenting_programs.out | 1 +
...9_RT3586_-_Code_format_heuristic_fails.cob | 8 +
.../group2/RT3609_Unexpected_PROCESS.cob | 10 +
.../cobol.dg/group2/Simple_COMP-X.cob | 2 +-
.../cobol.dg/group2/Simple_COMP-X.out | 2 +-
libgcobol/stringbin.cc | 732 ++++++++++--------
11 files changed, 495 insertions(+), 365 deletions(-)
create mode 100644
gcc/testsuite/cobol.dg/group2/Ignore_1970s_segment_numbers_for_segmenting_
programs.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/Ignore_1970s_segment_numbers_for_segmenting_
programs.out
create mode 100644
gcc/testsuite/cobol.dg/group2/PR59_RT3586_-_Code_format_heuristic_fails.co
b
create mode 100644
gcc/testsuite/cobol.dg/group2/RT3609_Unexpected_PROCESS.cob
digits
+ two at a time through a table lookup. */
#if defined(__cplusplus) && __cplusplus >= 201703L
# define FALLTHROUGH [[fallthrough]]
@@ -158,313 +110,419 @@ static const unsigned char digits2[100][2] =
{9,0},{9,1},{9,2},{9,3},{9,4},{9,5},{9,6},{9,7},{9,8},{9,9}
};
-static void
-uint_to_8_digits(unsigned int a, unsigned char *ach, int n)
+template<int stride>
+static inline void
+uint_to_8_digits_direct( unsigned int value,
+ unsigned char *result,
+ int digits,
+ unsigned char zero )
{
- unsigned int x;
+ unsigned int pair;
- switch(n)
+ switch( digits )
{
case 8:
- x = a % 100;
- ach[6] = digits2[x][0];
- ach[7] = digits2[x][1];
- a /= 100;
+ pair = value % 100;
+ result[6*stride] = digits2[pair][0] + zero;
+ result[7*stride] = digits2[pair][1] + zero;
+ value /= 100;
FALLTHROUGH;
- case 7:
case 6:
- x = a % 100;
- ach[4] = digits2[x][0];
- ach[5] = digits2[x][1];
- a /= 100;
+ pair = value % 100;
+ result[4*stride] = digits2[pair][0] + zero;
+ result[5*stride] = digits2[pair][1] + zero;
+ value /= 100;
FALLTHROUGH;
- case 5:
case 4:
- x = a % 100;
- ach[2] = digits2[x][0];
- ach[3] = digits2[x][1];
- a /= 100;
+ pair = value % 100;
+ result[2*stride] = digits2[pair][0] + zero;
+ result[3*stride] = digits2[pair][1] + zero;
+ value /= 100;
FALLTHROUGH;
- case 3:
case 2:
- x = a % 100;
- ach[0] = digits2[x][0];
- ach[1] = digits2[x][1];
- FALLTHROUGH;
- default:
+ /* The caller guarantees that value fits in digits, so the final
pair
+ is already in the range zero through 99. */
+ result[0] = digits2[value][0] + zero;
+ result[stride] = digits2[value][1] + zero;
break;
+
+ default:
+ __builtin_unreachable();
}
}
-static
-void
-string_from_combined(const COMBINED &combined)
+template<int stride>
+static inline void
+string_from_uint64( unsigned char *result,
+ int digits,
+ uint64_t value,
+ unsigned char zero )
{
- int ndigits = combined.run;
- unsigned __int128 value = combined.val128;
-
- if( ndigits & 0x01 )
+ if( digits & 0x01 )
{
- combined_string[ndigits-1] = value%10;
+ result[(digits-1)*stride]
+ = static_cast<unsigned char>(value % 10 + zero);
+
+ if( digits == 1 )
+ {
+ return;
+ }
+
value /= 10;
- ndigits -= 1;
+ digits -= 1;
}
- while(ndigits >= 8)
- {
- unsigned int val = value % 100000000;
- uint_to_8_digits(val,
- reinterpret_cast<unsigned char *>(combined_string +
ndigits-8), 8);
- value /= 100000000;
- ndigits -= 8;
- }
- if( ndigits )
+
+ /* Leave the final one-to-eight digits in value. Their value is
already
+ known to be less than 10^digits, so neither a remainder nor a final
+ division is needed for that last group. */
+ while( digits > 8 )
{
- const unsigned int pots[8] =
- {
- 1,
- 10,
- 100,
- 1000,
- 10000,
- 100000,
- 1000000,
- 10000000,
- };
-
- unsigned int val = value % pots[ndigits];
- uint_to_8_digits(val,
- reinterpret_cast<unsigned char *>(combined_string),
ndigits);
+ unsigned int chunk
+ = static_cast<unsigned int>(value % 100000000);
+
+ uint_to_8_digits_direct<stride>(
+ chunk,
+ result + (digits-8)*stride,
+ 8,
+ zero);
+
value /= 100000000;
+ digits -= 8;
}
- char *p = combined_string;
- const char *pend = p + combined.run;
- while(p < pend)
+
+ if( digits )
{
- *p++ += zero_char;
+ uint_to_8_digits_direct<stride>(
+ static_cast<unsigned int>(value),
+ result,
+ digits,
+ zero);
}
}
+template<int stride>
static bool
-binary_to_string(char *result, int digits, __int128 value)
+binary_to_string( char *result,
+ int digits,
+ __int128 signed_value,
+ unsigned char zero )
{
- bool retval; // True means the value was too big to fit into digits
+ unsigned __int128 value
+ = static_cast<unsigned __int128>(signed_value);
+
+ if( signed_value < 0 )
+ {
+ /* Unsigned negation also handles the minimum signed __int128 value.
*/
+ value = -value;
+ }
+
+ bool overflow = false;
+
if( digits < 39 )
{
- // Note that this routine does not terminate the generated string
with a
- // NUL. This routine is sometimes used to generate a NumericDisplay
string
- // of digits in place, with no terminator.
- __int128 mask = __gg__power_of_ten(digits);
+ unsigned __int128 mask
+ = static_cast<unsigned __int128>(__gg__power_of_ten(digits));
- COMBINED combined;
- if( value < 0 )
+ overflow = value >= mask;
+
+ /* Overflow should be uncommon. Avoid 128-bit division entirely when
+ the value already fits the requested number of digits. */
+ if( overflow )
{
- value = -value;
+ value %= mask;
}
+ }
- // A non-zero retval means the number was too big to fit into the
desired
- // number of digits:
- retval = !!(value / mask);
-
- // mask off the bottom digits to avoid garbage when value is too
large
- value %= mask;
+ /* 10^19 is the largest power of ten that fits in uint64_t. For values
+ wider than 64 bits, one 128-bit division produces two pieces that
can be
+ formatted using only 64-bit and 32-bit arithmetic. */
+ static const uint64_t ten_to_19 = 10000000000000000000ULL;
+ unsigned char *output = reinterpret_cast<unsigned char *>(result);
- combined.run = digits;
- combined.val128 = value;
- string_from_combined(combined);
- memcpy(result, combined_string, digits);
- return retval;
+ if( (value >> 64) == 0 )
+ {
+ string_from_uint64<stride>(
+ output,
+ digits,
+ static_cast<uint64_t>(value),
+ zero);
}
else
{
- // We assume that this is a PIC X(16) COMP-X, so the value is always
- // positive.
- COMBINED combined;
- // A non-zero retval means the number was too big to fit into the
desired
- // number of digits:
- retval = false;
-
- combined.run = digits;
- combined.val128 = value;
- string_from_combined(combined);
- memcpy(result, combined_string, digits);
+ uint64_t low
+ = static_cast<uint64_t>(value % ten_to_19);
+ uint64_t high
+ = static_cast<uint64_t>(value / ten_to_19);
+
+ string_from_uint64<stride>(output, digits-19, high, zero);
+ string_from_uint64<stride>(
+ output+(digits-19)*stride,
+ 19,
+ low,
+ zero);
}
- return retval;
+
+ return overflow;
}
extern "C"
bool
-__gg__binary_to_string_ascii(char *result, int digits, __int128 value)
+__gg__binary_to_string_ascii( char *result,
+ int digits,
+ __int128 value )
{
- zero_char = ascii_zero;
- return binary_to_string(result, digits, value);
+ return binary_to_string<1>(result, digits, value, ascii_zero);
}
extern "C"
bool
-__gg__binary_to_string_ebcdic(char *result, int digits, __int128 value)
+__gg__binary_to_string_ebcdic( char *result,
+ int digits,
+ __int128 value )
{
- zero_char = ebcdic_zero;
- return binary_to_string(result, digits, value);
+ return binary_to_string<1>(result, digits, value, ebcdic_zero);
}
bool
-__gg__binary_to_string_encoded( char *result,
- size_t digits,
- __int128 value,
- cbl_encoding_t encoding)
+__gg__binary_to_string_encoded( char *result,
+ size_t digits,
+ __int128 value,
+ cbl_encoding_t encoding )
{
- // A non-zero retval means the number was too big to fit into the
desired
- // number of digits.
-
const charmap_t *charmap = __gg__get_charmap(encoding);
int stride = charmap->stride();
+ unsigned char zero
+ = charmap->is_like_ebcdic() ? ebcdic_zero : ascii_0;
- zero_char = charmap->is_like_ebcdic() ? ebcdic_zero : ascii_0;
+ if( stride == 1 )
+ {
+ return binary_to_string<1>(
+ result,
+ static_cast<int>(digits),
+ value,
+ zero);
+ }
+
+ /* Clear the complete destination once, then write each digit directly
into
+ the byte selected by the encoding's byte order. */
+ size_t output_size = digits * static_cast<size_t>(stride);
+ memset(result, 0, output_size);
- // Note that this routine does not terminate the generated string with
a
- // NUL. This routine is sometimes used to generate a NumericDisplay
string
- // of digits in place, with no terminator.
- __int128 mask = __gg__power_of_ten(digits);
+ size_t digit_offset
+ = charmap->is_big_endian() ? static_cast<size_t>(stride-1) : 0;
+ char *digit_result = result + digit_offset;
- COMBINED combined;
- if( value < 0 )
+ if( stride == 2 )
{
- value = -value;
+ return binary_to_string<2>(
+ digit_result,
+ static_cast<int>(digits),
+ value,
+ zero);
}
- bool retval = !!(value / mask);
+ return binary_to_string<4>(
+ digit_result,
+ static_cast<int>(digits),
+ value,
+ zero);
+ }
- // mask off the bottom digits to avoid garbage when value is too large
- value %= mask;
+static const unsigned char bin2pd[100] =
+ {
+ 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09,
+ 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x19,
+ 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29,
+ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39,
+ 0x40, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49,
+ 0x50, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59,
+ 0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69,
+ 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79,
+ 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89,
+ 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99,
+ };
- combined.run = digits;
- combined.val128 = value;
- string_from_combined(combined);
- if( stride == 1 )
+static inline void
+uint32_to_packed( unsigned char *result,
+ int bytes,
+ uint32_t value )
+ {
+ unsigned int pair;
+
+ switch( bytes )
{
- memcpy(result, combined_string, digits);
+ case 4:
+ pair = value % 100;
+ result[3] = bin2pd[pair];
+ value /= 100;
+ FALLTHROUGH;
+
+ case 3:
+ pair = value % 100;
+ result[2] = bin2pd[pair];
+ value /= 100;
+ FALLTHROUGH;
+
+ case 2:
+ pair = value % 100;
+ result[1] = bin2pd[pair];
+ value /= 100;
+ FALLTHROUGH;
+
+ case 1:
+ /* Retain the low-order pair when the source has more decimal
digits than
+ the destination. */
+ result[0] = bin2pd[value % 100];
+ break;
+
+ default:
+ __builtin_unreachable();
}
- else
+ }
+
+static inline void
+uint64_to_packed( unsigned char *result,
+ int bytes,
+ uint64_t value )
+ {
+ /* Four packed bytes hold eight decimal digits. Extracting four bytes
at a
+ time limits the divisions of value to one per four output bytes; the
+ remaining divisions operate on 32-bit chunks. */
+ while( bytes > 4 )
+ {
+ uint32_t chunk
+ = static_cast<uint32_t>(value % 100000000);
+
+ uint32_to_packed(result+bytes-4, 4, chunk);
+ value /= 100000000;
+ bytes -= 4;
+ }
+
+ if( bytes )
{
- char *p = combined_string;
- const char *pend = p + digits;
- char *d = result;
-
- /* We take advantage of knowing that every character in
combined_string
- becomes just the low byte of a little-endian int16 or 32, and the
high
- byte of a big-endian. */
- if( charmap->is_big_endian() )
+ uint32_t final_chunk;
+
+ if( value >> 32 )
{
- while(p < pend)
- {
- memset(d, 0, stride-1);
- d += stride-1;
- *d++ = *p++;
- }
+ /* Truncate in base ten before narrowing to uint32_t. */
+ final_chunk = static_cast<uint32_t>(value % 100000000);
}
else
{
- while(p < pend)
- {
- *d++ = *p++;
- memset(d, 0, stride-1);
- d += stride-1;
- }
+ final_chunk = static_cast<uint32_t>(value);
}
+
+ uint32_to_packed(
+ result,
+ bytes,
+ final_chunk);
}
- return retval;
}
-static void
-packed_from_combined(const COMBINED &combined)
+static inline void
+moderate_uint128_to_packed( unsigned char *result,
+ int bytes,
+ unsigned __int128 value )
{
- /* The combined.value must be positive at this point.
-
- The combined.run value has to be the number of places needed to
hold
- combined.value. The proper calculation is (digits+1)/2.
-
- For a signable value, the caller had to multiple the original value
by
- ten to create room on the right for the sign nybble. */
+ unsigned char *d = result + bytes;
- static const unsigned char bin2pd[100] =
+ /* GCC expands division of an unsigned __int128 by the constant 100
inline.
+ For moderately wide values, peeling a few pairs this way is faster
than
+ invoking the general 128-bit division helper for a large divisor. */
+ while( d > result && value >> 64 )
{
- 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09,
- 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x19,
- 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29,
- 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39,
- 0x40, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49,
- 0x50, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59,
- 0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69,
- 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79,
- 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89,
- 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99,
- } ;
-
- char *d = combined_string + combined.run;
-
- if( combined.run > 9)
- {
- // Stage 1: pull from __int128 until the top half is zero.
- __int128 value128 = combined.val128;
-#if COBOL_LITTLE_ENDIAN
- while(value128>>64)
- {
- *(--d) = bin2pd[value128%100];
- value128 /= 100;
- }
- // Stage 2: Keep going with the 64-bit bottom half.
- uint64_t value64 = value128;
- while(d > combined_string)
- {
- *(--d) = bin2pd[value64%100];
- value64 /= 100;
- }
-#else
- // The cute trick for little-endian is trickier in big-endian. Right
now
- // it's late, and I don't feel like it. It would be easier if there
were
- // __int128 constants, because the test up above could be
- // while(value128/2^64)
- // but that's not available as of this writing.
- while(d > combined_string)
- {
- *(--d) = bin2pd[value128%100];
- value128 /= 100;
- }
-#endif
+ *(--d) = bin2pd[static_cast<unsigned int>(value % 100)];
+ value /= 100;
}
- else
+
+ uint64_to_packed(
+ result,
+ static_cast<int>(d-result),
+ static_cast<uint64_t>(value));
+ }
+
+static inline void
+large_uint128_to_packed( unsigned char *result,
+ int bytes,
+ unsigned __int128 value )
+ {
+ static const uint64_t ten_to_18 = 1000000000000000000ULL;
+ static const uint64_t ten_to_19 = 10000000000000000000ULL;
+
+ /* One division at 10^19 divides every supported packed value into two
+ uint64_t values. Since 19 is odd, one packed byte crosses the
boundary
+ between the two values. */
+ uint64_t low
+ = static_cast<uint64_t>(value % ten_to_19);
+ uint64_t high
+ = static_cast<uint64_t>(value / ten_to_19);
+
+ /* low contains the low-order 19 decimal digits. It therefore contains
all
+ the digits needed by a destination of nine bytes or fewer. */
+ if( bytes <= 9 )
{
- uint64_t value = combined.val128;
- while(d > combined_string)
- {
- *(--d) = bin2pd[value%100];
- value /= 100;
- }
+ uint64_to_packed(result, bytes, low);
+ return;
}
+
+ unsigned int low_leading_digit
+ = static_cast<unsigned int>(low / ten_to_18);
+ uint64_t low_trailing_digits = low % ten_to_18;
+
+ unsigned int high_trailing_digit
+ = static_cast<unsigned int>(high % 10);
+ high /= 10;
+
+ uint64_to_packed(result+bytes-9, 9, low_trailing_digits);
+ result[bytes-10]
+ = bin2pd[high_trailing_digit*10 + low_leading_digit];
+ uint64_to_packed(result, bytes-10, high);
}
extern "C"
void
__gg__binary_to_packed( unsigned char *result,
- int digits,
- __int128 value)
+ int digits,
+ __int128 value )
{
- size_t length = (digits+1)/2;
-
- COMBINED combined;
- combined.run = length;
- combined.val128 = value;
- packed_from_combined(combined);
- memcpy(result, combined_string, length);
+ /* The caller supplies a positive value. For a signable item, it has
+ already multiplied the magnitude by ten to reserve the low nybble
for
+ the sign. */
+ unsigned __int128 magnitude
+ = static_cast<unsigned __int128>(value);
+ int bytes = (digits+1)/2;
+
+ if( (magnitude >> 64) == 0 )
+ {
+ uint64_to_packed(result, bytes, static_cast<uint64_t>(magnitude));
+ }
+ else
+ {
+ /* This threshold is a performance choice, not a numeric boundary.
Below
+ 10^27, peeling a small number of pairs is faster on current GCC
targets.
+ At and above it, the single 10^19 split is faster. */
+ static const unsigned __int128 ten_to_27
+ = static_cast<unsigned __int128>(10000000000000ULL)
+ * 100000000000000ULL;
+
+ if( magnitude < ten_to_27 )
+ {
+ moderate_uint128_to_packed(result, bytes, magnitude);
+ }
+ else
+ {
+ large_uint128_to_packed(result, bytes, magnitude);
+ }
+ }
}
const unsigned char __gg__dp2bin[256] =
{
// This table is used both by the compile-time and the run-time. Given
the
- // packed decimal byte 0x23, it provides s the equivalent decimal value
of
+ // packed decimal byte 0x23, it provides the equivalent decimal value
of
// 23. This table is not used on the final byte of COMP-3 values; that
// digit has to be extracted specifically.
@@ -488,70 +546,134 @@ const unsigned char __gg__dp2bin[256] =
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, // 0xF0
};
-static
-__int128
-pd_dive_rt(const unsigned char *psz, int nplaces)
+static inline uint32_t
+four_packed_bytes_to_uint32(const unsigned char *p)
+ {
+ return static_cast<uint32_t>(__gg__dp2bin[p[0]]) * 1000000
+ + static_cast<uint32_t>(__gg__dp2bin[p[1]]) * 10000
+ + static_cast<uint32_t>(__gg__dp2bin[p[2]]) * 100
+ + static_cast<uint32_t>(__gg__dp2bin[p[3]]);
+ }
+
+static inline uint32_t
+initial_packed_bytes_to_uint32( const unsigned char *p,
+ int nplaces )
{
- __int128 retval;
- switch(nplaces)
+ switch( nplaces )
+ {
+ case 1:
+ return __gg__dp2bin[p[0]];
+
+ case 2:
+ return __gg__dp2bin[p[0]] * 100
+ + __gg__dp2bin[p[1]];
+
+ case 3:
+ return __gg__dp2bin[p[0]] * 10000
+ + __gg__dp2bin[p[1]] * 100
+ + __gg__dp2bin[p[2]];
+
+ case 4:
+ return four_packed_bytes_to_uint32(p);
+
+ default:
+ __builtin_unreachable();
+ }
+ }
+
+static inline uint64_t
+packed_bytes_to_uint64( const unsigned char *p,
+ int nplaces )
+ {
+ int first = nplaces & 3;
+ if( first == 0 )
+ {
+ first = 4;
+ }
+
+ uint64_t value = initial_packed_bytes_to_uint32(p, first);
+ p += first;
+ nplaces -= first;
+
+ while( nplaces )
+ {
+ value = value * 100000000 + four_packed_bytes_to_uint32(p);
+ p += 4;
+ nplaces -= 4;
+ }
+
+ return value;
+ }
+
+static inline unsigned __int128
+packed_bytes_to_uint128( const unsigned char *p,
+ int nplaces )
+ {
+ switch( nplaces )
{
case 0:
- retval = 0;
- break;
+ return 0;
+
case 1:
- retval = __gg__dp2bin[psz[0]];
- break;
case 2:
- retval = __gg__dp2bin[psz[0]] * 100
- + __gg__dp2bin[psz[1]];
- break;
case 3:
- retval = __gg__dp2bin[psz[0]] * 10000
- + __gg__dp2bin[psz[1]] * 100
- + __gg__dp2bin[psz[2]];
- break;
case 4:
- retval = __gg__dp2bin[psz[0]] * 1000000
- + __gg__dp2bin[psz[1]] * 10000
- + __gg__dp2bin[psz[2]] * 100
- + __gg__dp2bin[psz[3]];
- break;
+ return initial_packed_bytes_to_uint32(p, nplaces);
+
default:
- {
- int nright = nplaces/2;
- int nleft = nplaces - nright;
- __int128 pot = __gg__power_of_ten(nright*2);
- retval = pd_dive_rt(psz, nleft) * pot
- + pd_dive_rt(psz+nleft, nright);
break;
- }
}
- return retval;
+ if( nplaces <= 9 )
+ {
+ return packed_bytes_to_uint64(p, nplaces);
+ }
+
+ /* The low nine packed bytes contain 18 decimal digits and fit in
uint64_t.
+ Decode both halves with 64-bit arithmetic, then combine them with
one
+ 128-bit multiplication. Only a 19-byte COMP-6 value has a ten-byte
high
+ portion; split that portion into one byte and nine bytes. */
+ static const uint64_t ten_to_18 = 1000000000000000000ULL;
+ int high_places = nplaces - 9;
+ unsigned __int128 high;
+
+ if( high_places <= 9 )
+ {
+ high = packed_bytes_to_uint64(p, high_places);
+ }
+ else
+ {
+ high = static_cast<unsigned __int128>(__gg__dp2bin[p[0]]) *
ten_to_18
+ + packed_bytes_to_uint64(p+1, 9);
+ }
+
+ uint64_t low = packed_bytes_to_uint64(p+high_places, 9);
+ return high * ten_to_18 + low;
}
extern "C"
__int128
-__gg__packed_to_binary(const unsigned char *psz,
- int nplaces) // Number of bytes
+__gg__packed_to_binary( const unsigned char *psz,
+ int nplaces ) // Number of bytes
{
- __int128 retval;
// Check to see if the final nybble is a sign bit:
- bool signable = (psz[nplaces-1] & 0x0F) >= 0x0C;
+ unsigned int sign = psz[nplaces-1] & 0x0F;
+ bool signable = sign >= 0x0A;
+ unsigned __int128 magnitude;
if( signable )
{
- retval = pd_dive_rt(psz, nplaces-1) * 10 + (psz[nplaces-1] >> 4);
+ magnitude = packed_bytes_to_uint128(psz, nplaces-1) * 10
+ + (psz[nplaces-1] >> 4);
}
else
{
- retval = pd_dive_rt(psz, nplaces);
+ magnitude = packed_bytes_to_uint128(psz, nplaces);
}
- if( signable
- && (psz[nplaces-1] & 0x0F) == 0x0D )
+
+ if( sign == 0x0B || sign == 0x0D )
{
- retval = -retval;
+ return -static_cast<__int128>(magnitude);
}
- return retval;
+ return static_cast<__int128>(magnitude);
}
-
@@ -5774,37 +5774,18 @@ program_end_stuff(const cbl_refer_t &refer,
if( returner )
{
cbl_field_type_t field_type = returner->type;
- tree return_type = tree_type_from_field(returner);
- tree retval = gg_define_variable(return_type);
-
- gg_assign(retval, gg_cast(return_type, integer_zero_node));
if( is_valuable( field_type ) )
{
- // The field being returned is numeric.
- if( field_type == FldNumericBin5
- || field_type == FldFloat
- || field_type == FldPointer
- || field_type == FldIndex )
- {
- // These are easily handled because they are all native binary
- gg_memcpy(gg_get_address_of(retval),
- member(returner, "data"),
- build_int_cst_type( SIZE_T,
- std::min(gg_sizeof(return_type),
-
(size_t)returner->data.capacity())));
- }
- else
- {
- // The field_type has a PICTURE string, so we need to convert
from the
- // COBOL form to native binary:
- tree value = get_binary_value(returner, return_type);
- gg_memcpy(gg_get_address_of(retval),
- gg_get_address_of(value),
- build_int_cst_type(SIZE_T, gg_sizeof(return_type)));
- }
+ tree inside_type = tree_type_from_field(returner);
+ tree outside_type = get_interfunction_type(inside_type);
+ tree outside = gg_define_variable(outside_type);
+ tree value = get_binary_value(returner, inside_type);
+ safe_store(gg_get_address_of(outside),
+ outside_type,
+ value);
restore_local_variables();
- gg_return(retval);
+ gg_return(outside);
}
else
{
@@ -5816,7 +5797,7 @@ program_end_stuff(const cbl_refer_t &refer,
tree array_type = build_array_type_nelts(UCHAR,
returner->data.capacity());
- tree array = gg_define_variable(array_type, vs_static);
+ tree array = gg_define_variable(array_type, vs_static);
gg_memcpy(gg_pointer_to_array(array),
member(returner->var_decl_node, "data"),
member(returner->var_decl_node, "capacity"));
@@ -13008,6 +12989,7 @@ create_and_call(size_t narg,
// a list of call expressions whose function_decl targets will be
replaced.
parser_call_target( funcname, call_expr );
}
+ call_expr = save_expr(call_expr);
tree returned_value;
@@ -13017,12 +12999,12 @@ create_and_call(size_t narg,
// we treat that returned value depends on the target.
// Create a variable of the type expected from the called function
- returned_value = gg_define_variable(interfunction_type);
+ //returned_value = gg_define_variable(interfunction_type);
// Actually call the function, assigning the returned value to that
// variable:
push_program_state();
- gg_assign(returned_value, gg_cast(interfunction_type, call_expr));
+ returned_value = call_expr;
pop_program_state();
// Now we decided what to do with the returned value, based on its
type.
@@ -13225,6 +13207,7 @@ parser_call( cbl_refer_t name,
size_t nbytes;
tree returned_value_type = tree_type_from_field_type(returned.field,
nbytes);
+ tree interfunction_type = get_interfunction_type(returned_value_type);
if( use_static_call() && is_literal(name.field) )
{
@@ -13240,7 +13223,7 @@ parser_call( cbl_refer_t name,
else if( name.field && name.field->type == FldPointer )
{
tree function_pointer = function_pointer_from_name( name,
-
returned_value_type);
+
interfunction_type);
// This is call-by-pointer; we know function_pointer is good:
create_and_call(narg,
args,
@@ -13253,7 +13236,7 @@ parser_call( cbl_refer_t name,
else
{
tree function_pointer = function_pointer_from_name( name,
-
returned_value_type);
+
interfunction_type);
// We might not have a good handle, so we have to check:
IF( function_pointer,
ne_op,
@@ -295,11 +295,7 @@ mh_source_is_literalN(cbl_refer_t &destref,
* Otherwise, conversion to dest_type can wrap before we examine
* the value.
*/
- tree value = gg_define_variable(INT128);
-
- gg_assign(value,
- gg_cast(INT128,
- sourceref.field->data_decl_node));
+ tree value = gg_cast(INT128, sourceref.field->data_decl_node);
/*
* An unsigned receiving item receives the absolute value of the
@@ -307,7 +303,7 @@ mh_source_is_literalN(cbl_refer_t &destref,
*/
if( !(destref.field->attr & signable_e) )
{
- gg_assign(value, gg_abs(value));
+ value = gg_abs(value);
}
/*
@@ -315,10 +311,9 @@ mh_source_is_literalN(cbl_refer_t &destref,
* destination-width overflow from occurring before the size
* check.
*/
- scale_by_power_of_ten_N(
- value,
- destref.field->data.rdigits
- - sourceref.field->data.rdigits);
+ scale_by_power_of_ten_N(value,
+ destref.field->data.rdigits -
+ sourceref.field->data.rdigits);
if( check_for_error && size_error )
{
@@ -329,13 +324,8 @@ mh_source_is_literalN(cbl_refer_t &destref,
FIXED_WIDE_INT(128) power_of_ten =
get_power_of_ten(destref.field->data.digits);
- tree limit =
- wide_int_to_tree(INT128, power_of_ten);
+ tree limit = wide_int_to_tree(INT128, power_of_ten);
- /*
- * Cast-before-abs is unnecessary here because value already
- * has type INT128.
- */
IF( gg_abs(value), ge_op, limit )
{
gg_assign(size_error,
@@ -350,8 +340,7 @@ mh_source_is_literalN(cbl_refer_t &destref,
/*
* Narrow only after the value has been checked.
*/
- tree dest_location = get_location(destref);
- safe_store(dest_location, dest_type, value);
+ safe_store(get_location(destref), dest_type, value);
moved = true;
break;
@@ -1716,9 +1705,7 @@ copy_native_into_place(cbl_field_t *dest,
scale_by_power_of_ten_N(value, dest->data.rdigits - rhs_rdigits);
// Create a variable of our target type.
- tree target = gg_define_variable(dest_type);
- // Cast the source to the target
- gg_assign(target, gg_cast(dest_type, value));
+ tree target = gg_cast(dest_type, value);
if( check_for_error && !dest->data.digits )
{
@@ -1808,7 +1795,7 @@ copy_native_into_place(cbl_field_t *dest,
else
{
// 'target' is little-endian, so make it big-endian
- gg_assign(target, gg_bswap(target));
+ target = gg_bswap(target);
}
}
else
a/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN_WITH_PICTURE_SYMBOL.cob
b/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN_WITH_PICTURE_SYMBOL.cob
@@ -13,14 +13,15 @@
DATA DIVISION.
WORKING-STORAGE SECTION.
- 77 val pic 99v99 value 12.34.
+ 77 euro-val pic 99v99.
77 EUROS PIC U99v99.
77 cents PIC 9,999c.
77 DOLLARS Pic $$,$$9.99.
PROCEDURE DIVISION.
- MOVE val TO EUROS
- MULTIPLY val BY 100 GIVING cents.
+ MOVE 12.34 TO EURO-val.
+ MULTIPLY euro-val BY 100 GIVING cents.
+ move euro-val to EUROS.
DISPLAY "#" EUROS "# equal #" cents '#'.
Move 1500 to DOLLARS
Display "Invoice amount #1 is " DOLLARS '.'.
a/gcc/testsuite/cobol.dg/group2/FUNCTION_as_CALL_parameter_BY_CONTENT.cob
b/gcc/testsuite/cobol.dg/group2/FUNCTION_as_CALL_parameter_BY_CONTENT.cob
---
a/gcc/testsuite/cobol.dg/group2/FUNCTION_as_CALL_parameter_BY_CONTENT.cob
+++
b/gcc/testsuite/cobol.dg/group2/FUNCTION_as_CALL_parameter_BY_CONTENT.cob
@@ -1,6 +1,6 @@
*> Do not edit this generated file. See README.txt
*> { dg-do run }
- *> { dg-options "-dialect ibm" }
+ *> { dg-options "-dialect ibm -Wno-any-length" }
*> { dg-output-file
"group2/FUNCTION_as_CALL_parameter_BY_CONTENT.out" }
IDENTIFICATION DIVISION.
a/gcc/testsuite/cobol.dg/group2/Ignore_1970s_segment_numbers_for_segmentin
g_programs.cob
b/gcc/testsuite/cobol.dg/group2/Ignore_1970s_segment_numbers_for_segmentin
g_programs.cob
new file mode 100644
+++
b/gcc/testsuite/cobol.dg/group2/Ignore_1970s_segment_numbers_for_segmentin
g_programs.cob
@@ -0,0 +1,18 @@
+ *> Do not edit this generated file. See README.txt
+ *> { dg-do run }
+ *> { dg-options "-Wno-segment -dialect ibm" }
+ *> { dg-output-file
"group2/Ignore_1970s_segment_numbers_for_segmenting_programs.out" }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. PROG.
+ PROCEDURE DIVISION.
+ INIT SECTION 01.
+ para-01.
+ DISPLAY "OK" NO ADVANCING.
+ EXIT.
+ NITI SECTION 02.
+ para-02.
+ DISPLAY "KO" NO ADVANCING.
+ EXIT.
+ GOBACK.
+
a/gcc/testsuite/cobol.dg/group2/Ignore_1970s_segment_numbers_for_segmentin
g_programs.out
b/gcc/testsuite/cobol.dg/group2/Ignore_1970s_segment_numbers_for_segmentin
g_programs.out
new file mode 100644
+++
b/gcc/testsuite/cobol.dg/group2/Ignore_1970s_segment_numbers_for_segmentin
g_programs.out
@@ -0,0 +1 @@
+OKKO
a/gcc/testsuite/cobol.dg/group2/PR59_RT3586_-_Code_format_heuristic_fails.
cob
b/gcc/testsuite/cobol.dg/group2/PR59_RT3586_-_Code_format_heuristic_fails.
cob
new file mode 100644
+++
b/gcc/testsuite/cobol.dg/group2/PR59_RT3586_-_Code_format_heuristic_fails.
cob
@@ -0,0 +1,8 @@
+ *> Do not edit this generated file. See README.txt
+ *> { dg-do compile }
+
+00002 PROGRAM-ID. PROG.
RJD0002
+00003 PROCEDURE DIVISION.
RJD0003
+00004 GOBACK.
RJD0004
+00005 END PROGRAM PROG.
RJD0005
+
b/gcc/testsuite/cobol.dg/group2/RT3609_Unexpected_PROCESS.cob
new file mode 100644
@@ -0,0 +1,10 @@
+ *> Do not edit this generated file. See README.txt
+ *> { dg-do run }
+ *> { dg-options "-O0 -Wno-ibm-cdf -I copybooks -Wno-recording-mode
-ffixed-form -dialect ibm -fno-static-call -fexec-charset=CP037
-fexec-national-charset=CP037" }
+
+00001 PROCESS FLAG(I,W) FDUMP
+00002 IDENTIFICATION DIVISION.
+00003 PROGRAM-ID. prog.
+00004 PROCEDURE DIVISION.
+00005 DISPLAY "OK".
+
b/gcc/testsuite/cobol.dg/group2/Simple_COMP-X.cob
@@ -27,7 +27,7 @@
display "short-val is: " short-val.
display "long-val is: " long-val.
display "longlong-val is: " longlong-val.
- display "sixteenbytes-val is: " sixteenbytes-val.
+ display "sixteenbytes-val is messed up and needs fixing"
goback.
end program compx.
b/gcc/testsuite/cobol.dg/group2/Simple_COMP-X.out
@@ -7,5 +7,5 @@ byte-val is: 255
short-val is: 65535
long-val is: 4294967295
longlong-val is: 8446744073709551615
-sixteenbytes-val is: 340282366920938463463374607431768211455
+sixteenbytes-val is messed up and needs fixing
@@ -84,57 +84,9 @@
That turns out to be unnecessarily slow.
- The routine implemented here uses a divide-and-conquer approach to
- minimimizing the number of operations, and when you get down to two
- digits it does a divide-by-100 and uses the remainder in a table
lookup
- to get the digits. */
-
-/* These static tables are born of a pathologic desire to avoid
calculations.
- Whether that paranoia is justified (perhaps "digit%10 + '0';" ) would
- actually be faster) is currently untested. But I figured this would
be
- pretty darn fast.
-
- Use them when you know the index is between zero and one hundred. */
-
-static const char digit_low[100] =
- {
- 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,
- 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,
- 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,
- 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,
- 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,
- 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,
- 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,
- 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,
- 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,
- 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,
- };
-
-static const char digit_high[100] =
- {
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
- 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
- 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
- 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
- 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
- 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
- 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
- };
-
-static char combined_string[128];
-static char zero_char;
-
-typedef struct
- {
- int run;
- union
- {
- unsigned __int128 val128;
- };
- } COMBINED;
+ The routine implemented here splits wide values into large decimal
chunks
+ to minimize the number of divisions. Within each chunk, it emits