Blame stacksize

Packit 14c646
#!/usr/bin/perl
Packit 14c646
# binary search maximum stack depth for arrays and hashes
Packit 14c646
# and store it in lib/Storable/Limit.pm
Packit 14c646
Packit 14c646
use Config;
Packit 14c646
use Cwd;
Packit 14c646
use File::Spec;
Packit 14c646
use strict;
Packit 14c646
Packit 14c646
my $fn = "lib/Storable/Limit.pm";
Packit 14c646
my $ptrsize = $Config{ptrsize};
Packit 14c646
my ($bad1, $bad2) = (65001, 25000);
Packit 14c646
sub QUIET () {
Packit 14c646
    (defined $ENV{MAKEFLAGS} and $ENV{MAKEFLAGS} =~ /\b(s|silent|quiet)\b/
Packit 14c646
     and !defined($ENV{TRAVIS}))
Packit 14c646
      ? 1 : 0
Packit 14c646
}
Packit 14c646
sub PARALLEL () {
Packit 14c646
    if (defined $ENV{MAKEFLAGS}
Packit 14c646
        and $ENV{MAKEFLAGS} =~ /\bj\s*(\d+)\b/
Packit 14c646
        and $1 > 1) {
Packit 14c646
        return 1;
Packit 14c646
    } else {
Packit 14c646
        return 0;
Packit 14c646
    }
Packit 14c646
}
Packit 14c646
sub is_miniperl {
Packit 14c646
    return !defined &DynaLoader::boot_DynaLoader;
Packit 14c646
}
Packit 14c646
Packit 14c646
if (is_miniperl()) {
Packit 14c646
    die "Should not run during miniperl\n";
Packit 14c646
}
Packit 14c646
my $prefix = "";
Packit 14c646
if ($^O eq "MSWin32") {
Packit 14c646
    # prevent Windows popping up a dialog each time we overflow
Packit 14c646
    # the stack
Packit 14c646
    require Win32API::File;
Packit 14c646
    Win32API::File->import(qw(SetErrorMode SEM_NOGPFAULTERRORBOX SEM_FAILCRITICALERRORS));
Packit 14c646
    SetErrorMode(SEM_NOGPFAULTERRORBOX() | SEM_FAILCRITICALERRORS());
Packit 14c646
}
Packit 14c646
# the ; here is to ensure system() passes this to the shell
Packit 14c646
elsif (system("ulimit -c 0 ;") == 0) {
Packit 14c646
    # try to prevent core dumps
Packit 14c646
    $prefix = "ulimit -c 0 ; ";
Packit 14c646
}
Packit 14c646
if (@ARGV and $ARGV[0] eq '--core') {
Packit 14c646
    $ENV{PERL_CORE} = 1;
Packit 14c646
}
Packit 14c646
my $PERL = $^X;
Packit 14c646
if ($ENV{PERL_CORE}) {
Packit 14c646
    my $path;
Packit 14c646
    my $ldlib = $Config{ldlibpthname};
Packit 14c646
    if (-d 'dist/Storable') {
Packit 14c646
        chdir 'dist/Storable';
Packit 14c646
        $PERL = "../../$PERL" unless $PERL =~ m|^/|;
Packit 14c646
    }
Packit 14c646
    if ($ldlib) {
Packit 14c646
        $path = getcwd()."/../..";
Packit 14c646
    }
Packit 14c646
    if ($^O eq 'MSWin32' and -d '../dist/Storable') {
Packit 14c646
        chdir '..\dist\Storable';
Packit 14c646
        $PERL = "..\\..\\$PERL" unless $PERL =~ /^[A-Za-z]:\\/;
Packit 14c646
    }
Packit 14c646
    $PERL = "\"$PERL\"" if $PERL =~ / /;
Packit 14c646
    if ($ldlib and $ldlib ne 'PATH') {
Packit 14c646
        $PERL = "$ldlib=$path $PERL";
Packit 14c646
    }
Packit 14c646
}
Packit 14c646
Packit 14c646
-d "lib" or mkdir "lib";
Packit 14c646
-d "lib/Storable" or mkdir "lib/Storable";
Packit 14c646
Packit 14c646
if ($^O eq "MSWin32") {
Packit 14c646
    require Win32;
Packit 14c646
    my ($str, $major, $minor) = Win32::GetOSVersion();
Packit 14c646
    if ($major < 6 || $major == 6 && $minor < 1) {
Packit 14c646
	print "Using defaults for older Win32\n";
Packit 14c646
	write_limits(500, 256);
Packit 14c646
	exit;
Packit 14c646
    }
Packit 14c646
}
Packit 14c646
my ($n, $good, $bad, $found) =
Packit 14c646
    (65000, 100, $bad1, undef);
Packit 14c646
print "probe for max. stack sizes...\n" unless QUIET;
Packit 14c646
# -I. since we're run before pm_to_blib (which is going to copy the
Packit 14c646
# file we create) and need to load our Storable.pm, not the already
Packit 14c646
# installed Storable.pm
Packit 14c646
my $mblib = '-Mblib -I.';
Packit 14c646
if ($ENV{PERL_CORE}) {
Packit 14c646
    if ($^O eq 'MSWin32') {
Packit 14c646
        $mblib = '-I..\..\lib\auto -I..\..\lib';
Packit 14c646
    } else {
Packit 14c646
        $mblib = '-I../../lib/auto -I../../lib';
Packit 14c646
    }
Packit 14c646
}
Packit 14c646
if (PARALLEL) {
Packit 14c646
    # problem with parallel builds. wait for INST_DYNAMIC linking to be done.
Packit 14c646
    # the problem is the RM_F INST_DYNAMIC race.
Packit 14c646
    print "parallel build race - wait for linker ...\n" unless QUIET;
Packit 14c646
    sleep(2.0);
Packit 14c646
}
Packit 14c646
Packit 14c646
sub cmd {
Packit 14c646
    my ($i, $try, $limit_name) = @_;
Packit 14c646
    die unless $i;
Packit 14c646
    my $code = "my \$t; \$Storable::$limit_name = -1; $try for 1..$i;dclone(\$t); print qq/ok\n/";
Packit 14c646
    my $q = ($^O eq 'MSWin32') ? '"' : "'";
Packit 14c646
Packit 14c646
    "$prefix $PERL $mblib -MStorable=dclone -e$q$code$q"
Packit 14c646
}
Packit 14c646
# try more
Packit 14c646
sub good {
Packit 14c646
    my $i = shift; # this passed
Packit 14c646
    my $j = $i + abs(int(($bad - $i) / 2));
Packit 14c646
    print "Storable: determining recursion limit: $i passed, try more $j ...\n" unless QUIET;
Packit 14c646
    $good = $i;
Packit 14c646
    if ($j <= $i) {
Packit 14c646
        $found++;
Packit 14c646
    }
Packit 14c646
    return $j;
Packit 14c646
}
Packit 14c646
# try less
Packit 14c646
sub bad {
Packit 14c646
    my $i = shift; # this failed
Packit 14c646
    my $j = $i - abs(int(($i - $good) / 2));
Packit 14c646
    print "Storable: determining recursion limit: $i too big, try less $j ...\n" unless QUIET;
Packit 14c646
    $bad = $i;
Packit 14c646
    if ($j >= $i) {
Packit 14c646
        $j = $good;
Packit 14c646
        $found++;
Packit 14c646
    }
Packit 14c646
    return $j;
Packit 14c646
}
Packit 14c646
Packit 14c646
sub array_cmd {
Packit 14c646
    my $depth = shift;
Packit 14c646
    return cmd($depth, '$t=[$t]', 'recursion_limit');
Packit 14c646
}
Packit 14c646
Packit 14c646
# first check we can successfully run with a minimum level
Packit 14c646
my $cmd = array_cmd(1);
Packit 14c646
unless ((my $output = `$cmd`) =~ /\bok\b/) {
Packit 14c646
    die "Cannot run probe: '$output', aborting...\n";
Packit 14c646
}
Packit 14c646
Packit 14c646
unless ($ENV{STORABLE_NOISY}) {
Packit 14c646
    # suppress Segmentation fault messages
Packit 14c646
    open STDERR, ">", File::Spec->devnull;
Packit 14c646
}
Packit 14c646
Packit 14c646
while (!$found) {
Packit 14c646
    my $cmd = array_cmd($n);
Packit 14c646
    #print "$cmd\n" unless $QUIET;
Packit 14c646
    if (`$cmd` =~ /\bok\b/) {
Packit 14c646
        $n = good($n);
Packit 14c646
    } else {
Packit 14c646
        $n = bad($n);
Packit 14c646
    }
Packit 14c646
}
Packit 14c646
print "MAX_DEPTH = $n\n" unless QUIET;
Packit 14c646
my $max_depth = $n;
Packit 14c646
Packit 14c646
($n, $good, $bad, $found) =
Packit 14c646
  (int($n/2), 50, $n, undef);
Packit 14c646
# pack j only since 5.8
Packit 14c646
my $max = ($] > 5.007 and length(pack "j", 0) < 8)
Packit 14c646
  ? ($^O eq 'MSWin32' ? 3000 : 8000)
Packit 14c646
  : $max_depth;
Packit 14c646
$n = $max if $n > $max;
Packit 14c646
$bad = $max if $bad > $max;
Packit 14c646
while (!$found) {
Packit 14c646
    my $cmd = cmd($n, '$t={1=>$t}', 'recursion_limit_hash');
Packit 14c646
    #print "$cmd\n" unless $QUIET;
Packit 14c646
    if (`$cmd` =~ /\bok\b/) {
Packit 14c646
        $n = good($n);
Packit 14c646
    } else {
Packit 14c646
        $n = bad($n);
Packit 14c646
    }
Packit 14c646
}
Packit 14c646
if ($max_depth == $bad1-1
Packit 14c646
    and $n == $bad2-1)
Packit 14c646
{
Packit 14c646
    # more likely the shell. travis docker ubuntu, mingw e.g.
Packit 14c646
    print "Error: Apparently your system(SHELLSTRING) cannot catch stack overflows\n"
Packit 14c646
      unless QUIET;
Packit 14c646
    $max_depth = 512;
Packit 14c646
    $n = 256;
Packit 14c646
    print "MAX_DEPTH = $max_depth\n" unless QUIET;
Packit 14c646
}
Packit 14c646
print "MAX_DEPTH_HASH = $n\n" unless QUIET;
Packit 14c646
my $max_depth_hash = $n;
Packit 14c646
Packit 14c646
# Previously this calculation was done in the macro, calculate it here
Packit 14c646
# instead so a user setting of either variable more closely matches
Packit 14c646
# the limits the use sees.
Packit 14c646
Packit 14c646
# be fairly aggressive in trimming this, smoke testing showed several
Packit 14c646
# several apparently random failures here, eg. working in one
Packit 14c646
# configuration, but not in a very similar configuration.
Packit 14c646
$max_depth = int(0.6 * $max_depth);
Packit 14c646
$max_depth_hash = int(0.6 * $max_depth);
Packit 14c646
Packit 14c646
my $stack_reserve = $^O eq "MSWin32" ? 32 : 16;
Packit 14c646
if ($] ge "5.016" && !($^O eq "cygwin" && $ptrsize == 8)) {
Packit 14c646
    $max_depth -= $stack_reserve;
Packit 14c646
    $max_depth_hash -= $stack_reserve;
Packit 14c646
}
Packit 14c646
else {
Packit 14c646
    # within the exception we need another stack depth to recursively
Packit 14c646
    # cleanup the hash
Packit 14c646
    $max_depth = ($max_depth >> 1) - $stack_reserve;
Packit 14c646
    $max_depth_hash = ($max_depth_hash >> 1) - $stack_reserve * 2;
Packit 14c646
}
Packit 14c646
Packit 14c646
write_limits($max_depth, $max_depth_hash);
Packit 14c646
Packit 14c646
sub write_limits {
Packit 14c646
    my ($max_depth, $max_depth_hash) = @_;
Packit 14c646
    my $f;
Packit 14c646
    open $f, ">", $fn or die "$fn $!";
Packit 14c646
    print $f <
Packit 14c646
# bisected by stacksize
Packit 14c646
\$Storable::recursion_limit = $max_depth
Packit 14c646
  unless defined \$Storable::recursion_limit;
Packit 14c646
\$Storable::recursion_limit_hash = $max_depth_hash
Packit 14c646
  unless defined \$Storable::recursion_limit_hash;
Packit 14c646
1;
Packit 14c646
EOS
Packit 14c646
    close $f
Packit 14c646
      or die "Failed to close $fn: $!\n";
Packit 14c646
}