diff options
| -rw-r--r-- | perl.c | 22 | ||||
| -rw-r--r-- | pp.c | 54 | ||||
| -rw-r--r-- | pp_proto.h | 5 | ||||
| -rwxr-xr-x | regen/opcode.pl | 25 |
4 files changed, 50 insertions, 56 deletions
@@ -214,6 +214,26 @@ Initializes a new Perl interpreter. See L<perlembed>. =cut */ +static void +S_fixup_platform_bugs(void) +{ +#if defined(__GLIBC__) && IVSIZE == 8 \ + && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8)) + { + IV l = 3; + IV r = -10; + /* Cannot do this check with inlined IV constants since + * that seems to work correctly even with the buggy glibc. */ + if (l % r == -3) { + dTHX; + /* Yikes, we have the bug. + * Patch in the workaround version. */ + PL_ppaddr[OP_I_MODULO] = &Perl_pp_i_modulo_glibc_bugfix; + } + } +#endif +} + void perl_construct(pTHXx) { @@ -251,6 +271,8 @@ perl_construct(pTHXx) init_ids(); + S_fixup_platform_bugs(); + JMPENV_BOOTSTRAP; STATUS_ALL_SUCCESS; @@ -2785,13 +2785,7 @@ PP(pp_i_divide) } } -#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \ - && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8)) -STATIC -PP(pp_i_modulo_0) -#else PP(pp_i_modulo) -#endif { /* This is the vanilla old i_modulo. */ dSP; dATARGET; @@ -2809,11 +2803,10 @@ PP(pp_i_modulo) } } -#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \ +#if defined(__GLIBC__) && IVSIZE == 8 \ && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8)) -STATIC -PP(pp_i_modulo_1) +PP(pp_i_modulo_glibc_bugfix) { /* This is the i_modulo with the workaround for the _moddi3 bug * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround). @@ -2832,49 +2825,6 @@ PP(pp_i_modulo_1) RETURN; } } - -PP(pp_i_modulo) -{ - dVAR; dSP; dATARGET; - tryAMAGICbin_MG(modulo_amg, AMGf_assign); - { - dPOPTOPiirl_nomg; - if (!right) - DIE(aTHX_ "Illegal modulus zero"); - /* The assumption is to use hereafter the old vanilla version... */ - PL_op->op_ppaddr = - PL_ppaddr[OP_I_MODULO] = - Perl_pp_i_modulo_0; - /* .. but if we have glibc, we might have a buggy _moddi3 - * (at least glibc 2.2.5 is known to have this bug), in other - * words our integer modulus with negative quad as the second - * argument might be broken. Test for this and re-patch the - * opcode dispatch table if that is the case, remembering to - * also apply the workaround so that this first round works - * right, too. See [perl #9402] for more information. */ - { - IV l = 3; - IV r = -10; - /* Cannot do this check with inlined IV constants since - * that seems to work correctly even with the buggy glibc. */ - if (l % r == -3) { - /* Yikes, we have the bug. - * Patch in the workaround version. */ - PL_op->op_ppaddr = - PL_ppaddr[OP_I_MODULO] = - &Perl_pp_i_modulo_1; - /* Make certain we work right this time, too. */ - right = PERL_ABS(right); - } - } - /* avoid FPE_INTOVF on some platforms when left is IV_MIN */ - if (right == -1) - SETi( 0 ); - else - SETi( left % right ); - RETURN; - } -} #endif PP(pp_i_add) diff --git a/pp_proto.h b/pp_proto.h index f919313ed1..17241d38ea 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -293,4 +293,9 @@ PERL_CALLCONV OP *Perl_pp_warn(pTHX); PERL_CALLCONV OP *Perl_pp_xor(pTHX); PERL_CALLCONV OP *Perl_unimplemented_op(pTHX); +/* alternative functions */ +#if defined(__GLIBC__) && IVSIZE == 8 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8)) +PERL_CALLCONV OP *Perl_pp_i_modulo_glibc_bugfix(pTHX); +#endif + /* ex: set ro: */ diff --git a/regen/opcode.pl b/regen/opcode.pl index 82454bbb48..edb9f4d7c1 100755 --- a/regen/opcode.pl +++ b/regen/opcode.pl @@ -71,9 +71,9 @@ while (<OPS>) { $args{$key} = $args; } -# Set up aliases +# Set up aliases, and alternative funcs -my %alias; +my (%alias, %alts); # Format is "this function" => "does these op names" my @raw_alias = ( @@ -139,16 +139,25 @@ my @raw_alias = ( Perl_pp_shostent => [qw(snetent sprotoent sservent)], Perl_pp_aelemfast => ['aelemfast_lex'], Perl_pp_grepstart => ['mapstart'], + + # 2 i_modulo mappings: 2nd is alt, needs 1st (explicit default) to not override the default + Perl_pp_i_modulo => ['i_modulo'], + Perl_pp_i_modulo_glibc_bugfix => { + 'i_modulo' => + '#if defined(__GLIBC__) && IVSIZE == 8 '. + ' && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))' }, ); while (my ($func, $names) = splice @raw_alias, 0, 2) { if (ref $names eq 'ARRAY') { foreach (@$names) { - $alias{$_} = [$func, '']; + defined $alias{$_} + ? $alts{$_} : $alias{$_} = [$func, '']; } } else { while (my ($opname, $cond) = each %$names) { - $alias{$opname} = [$func, $cond]; + defined $alias{$opname} + ? $alts{$opname} : $alias{$opname} = [$func, $cond]; } } } @@ -1251,6 +1260,14 @@ my $pp = open_new('pp_proto.h', '>', ++$funcs{$name}; } print $pp "PERL_CALLCONV OP *$_(pTHX);\n" foreach sort keys %funcs; + + print $pp "\n/* alternative functions */\n" if keys %alts; + for my $fn (sort keys %alts) { + my ($x, $cond) = @{$alts{$fn}}; + print $pp "$cond\n" if $cond; + print $pp "PERL_CALLCONV OP *$x(pTHX);\n"; + print $pp "#endif\n" if $cond; + } } print $oc "\n\n"; |