This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
a698726fde0d6a751e599c0463283a1c8905c66c
[perl5.git] / dist / Storable / stacksize
1 #!/usr/bin/perl
2 # binary search maximum stack depth for arrays and hashes
3 # and store it in lib/Storable/Limit.pm
4
5 use Config;
6 use Cwd;
7 use strict;
8
9 my $fn = "lib/Storable/Limit.pm";
10 my $ptrsize = $Config{ptrsize};
11 my ($bad1, $bad2) = (65001, 25000);
12 sub QUIET () {
13     (defined $ENV{MAKEFLAGS} and $ENV{MAKEFLAGS} =~ /\b(s|silent|quiet)\b/
14      and !defined($ENV{TRAVIS}))
15       ? 1 : 0
16 }
17 sub PARALLEL () {
18     if (defined $ENV{MAKEFLAGS}
19         and $ENV{MAKEFLAGS} =~ /\bj\s*(\d+)\b/
20         and $1 > 1) {
21         return 1;
22     } else {
23         return 0;
24     }
25 }
26 sub is_miniperl {
27     return !defined &DynaLoader::boot_DynaLoader;
28 }
29
30 if (is_miniperl()) {
31     die "Should not run during miniperl\n";
32 }
33 my $prefix = "";
34 if ($^O eq "MSWin32") {
35     # prevent Windows popping up a dialog each time we overflow
36     # the stack
37     require Win32API::File;
38     Win32API::File->import(qw(SetErrorMode SEM_NOGPFAULTERRORBOX SEM_FAILCRITICALERRORS));
39     SetErrorMode(SEM_NOGPFAULTERRORBOX() | SEM_FAILCRITICALERRORS());
40 }
41 # the ; here is to ensure system() passes this to the shell
42 elsif (system("ulimit -c 0 ;") == 0) {
43     # try to prevent core dumps
44     $prefix = "ulimit -c 0 ; ";
45 }
46 if (@ARGV and $ARGV[0] eq '--core') {
47     $ENV{PERL_CORE} = 1;
48 }
49 my $PERL = $^X;
50 if ($ENV{PERL_CORE}) {
51     my $path;
52     my $ldlib = $Config{ldlibpthname};
53     if (-d 'dist/Storable') {
54         chdir 'dist/Storable';
55         $PERL = "../../$PERL" unless $PERL =~ m|^/|;
56     }
57     if ($ldlib) {
58         $path = getcwd()."/../..";
59     }
60     if ($^O eq 'MSWin32' and -d '../dist/Storable') {
61         chdir '..\dist\Storable';
62         $PERL = "..\\..\\$PERL" unless $PERL =~ /^[A-Za-z]:\\/;
63     }
64     $PERL = "\"$PERL\"" if $PERL =~ / /;
65     if ($ldlib and $ldlib ne 'PATH') {
66         $PERL = "$ldlib=$path $PERL";
67     }
68 }
69
70 -d "lib" or mkdir "lib";
71 -d "lib/Storable" or mkdir "lib/Storable";
72
73 my ($n, $good, $bad, $found) =
74     (65000, 100, $bad1, undef);
75 print "probe for max. stack sizes...\n" unless QUIET;
76 # -I. since we're run before pm_to_blib (which is going to copy the
77 # file we create) and need to load our Storable.pm, not the already
78 # installed Storable.pm
79 my $mblib = '-Mblib -I.';
80 if ($ENV{PERL_CORE}) {
81     if ($^O eq 'MSWin32') {
82         $mblib = '-I..\..\lib\auto -I..\..\lib';
83     } else {
84         $mblib = '-I../../lib/auto -I../../lib';
85     }
86 }
87 if (PARALLEL) {
88     # problem with parallel builds. wait for INST_DYNAMIC linking to be done.
89     # the problem is the RM_F INST_DYNAMIC race.
90     print "parallel build race - wait for linker ...\n" unless QUIET;
91     sleep(2.0);
92 }
93
94 sub cmd {
95     my ($i, $try, $limit_name) = @_;
96     die unless $i;
97     my $code = "my \$t; \$Storable::$limit_name = -1; $try for 1..$i;dclone(\$t);";
98     my $q = ($^O eq 'MSWin32') ? '"' : "'";
99
100     "$prefix $PERL $mblib -MStorable=dclone -e$q$code$q"
101 }
102 # try more
103 sub good {
104     my $i = shift; # this passed
105     my $j = $i + abs(int(($bad - $i) / 2));
106     print "Storable: determining recursion limit: $i passed, try more $j ...\n" unless QUIET;
107     $good = $i;
108     if ($j <= $i) {
109         $found++;
110     }
111     return $j;
112 }
113 # try less
114 sub bad {
115     my $i = shift; # this failed
116     my $j = $i - abs(int(($i - $good) / 2));
117     print "Storable: determining recursion limit: $i too big, try less $j ...\n" unless QUIET;
118     $bad = $i;
119     if ($j >= $i) {
120         $j = $good;
121         $found++;
122     }
123     return $j;
124 }
125
126 while (!$found) {
127     my $cmd = cmd($n, '$t=[$t]', 'recursion_limit');
128     #print "$cmd\n" unless $QUIET;
129     if (system($cmd) == 0) {
130         $n = good($n);
131     } else {
132         $n = bad($n);
133     }
134 }
135 print "MAX_DEPTH = $n\n" unless QUIET;
136 my $max_depth = $n;
137
138 ($n, $good, $bad, $found) =
139   (int($n/2), 50, $n, undef);
140 # pack j only since 5.8
141 my $max = ($] > 5.007 and length(pack "j", 0) < 8)
142   ? ($^O eq 'MSWin32' ? 3000 : 8000)
143   : $max_depth;
144 $n = $max if $n > $max;
145 $bad = $max if $bad > $max;
146 while (!$found) {
147     my $cmd = cmd($n, '$t={1=>$t}', 'recursion_limit_hash');
148     #print "$cmd\n" unless $QUIET;
149     if (system($cmd) == 0) {
150         $n = good($n);
151     } else {
152         $n = bad($n);
153     }
154 }
155 if ($max_depth == $bad1-1
156     and $n == $bad2-1)
157 {
158     # more likely the shell. travis docker ubuntu, mingw e.g.
159     print "Error: Apparently your system(SHELLSTRING) cannot catch stack overflows\n"
160       unless QUIET;
161     $max_depth = 512;
162     $n = 256;
163     print "MAX_DEPTH = $max_depth\n" unless QUIET;
164 }
165 print "MAX_DEPTH_HASH = $n\n" unless QUIET;
166 my $max_depth_hash = $n;
167
168 # Previously this calculation was done in the macro, calculate it here
169 # instead so a user setting of either variable more closely matches
170 # the limits the use sees.
171
172 # be fairly aggressive in trimming this, smoke testing showed several
173 # several apparently random failures here, eg. working in one
174 # configuration, but not in a very similar configuration.
175 $max_depth = int(0.6 * $max_depth);
176 $max_depth_hash = int(0.6 * $max_depth);
177
178 my $stack_reserve = $^O eq "MSWin32" ? 32 : 16;
179 if ($] ge "5.016" && !($^O eq "cygwin" && $ptrsize == 8)) {
180     $max_depth -= $stack_reserve;
181     $max_depth_hash -= $stack_reserve;
182 }
183 else {
184     # within the exception we need another stack depth to recursively
185     # cleanup the hash
186     $max_depth = ($max_depth >> 1) - $stack_reserve;
187     $max_depth_hash = ($max_depth_hash >> 1) - $stack_reserve * 2;
188 }
189
190 my $f;
191 open $f, ">", $fn or die "$fn $!";
192 print $f <<EOS;
193 # bisected by stacksize
194 \$Storable::recursion_limit = $max_depth
195   unless defined \$Storable::recursion_limit;
196 \$Storable::recursion_limit_hash = $max_depth_hash
197   unless defined \$Storable::recursion_limit_hash;
198 1;
199 EOS
200 close $f;