Commit | Line | Data |
ae12fecd |
1 | #!/usr/bin/perl -w |
2 | |
3 | use strict; |
4 | use Test::More tests => 44; |
d3b8a135 |
5 | use Devel::Memory ':all'; |
ae12fecd |
6 | use Config; |
7 | |
8 | my $warn_count; |
9 | |
10 | $SIG{__WARN__} = sub { |
d3b8a135 |
11 | return if $_[0] =~ "Can't size up perlio layers yet\n"; |
ae12fecd |
12 | ++$warn_count; |
13 | warn @_; |
14 | }; |
15 | |
16 | { |
17 | my @array = (\undef, \undef, \undef); |
18 | my $array_overhead = total_size(\@array); |
19 | cmp_ok($array_overhead, '>', 0, 'Array has a positive size'); |
20 | |
21 | my $real_gv_size = total_size(*PFLAP); |
22 | cmp_ok($real_gv_size, '>', 0, 'GVs have a positive size'); |
23 | |
24 | # Eventually DonMartin gives up enough same-length names: |
25 | $array[0] = \*PFLAP; |
26 | |
27 | my $with_one = total_size(\@array); |
28 | is($with_one, $array_overhead + $real_gv_size, |
29 | 'agregate size is overhead plus GV'); |
30 | |
31 | $array[1] = \*CHOMP; |
32 | |
33 | my $with_two = total_size(\@array); |
34 | cmp_ok($with_two, '>', $with_one, 'agregate size for 2 GVs is larger'); |
35 | # GvFILE may well be shared: |
36 | cmp_ok($with_two, '<=', $with_one + $real_gv_size, |
37 | 'agregate size for 2 GVs is not larger than overhead plus 2 GVs'); |
38 | |
39 | my $incremental_gv_size = $with_two - $with_one; |
40 | my $gv_shared = $real_gv_size - $incremental_gv_size; |
41 | |
42 | $array[2] = \*KSSSH; |
43 | |
44 | is(total_size(\@array), $with_one + 2 * $incremental_gv_size, |
45 | "linear growth for 1, 2 and 3 GVs - $gv_shared bytes are shared"); |
46 | |
47 | $array[2] = \undef; |
48 | *CHOMP = \*PFLAP; |
49 | |
50 | my $two_aliased = total_size(\@array); |
51 | cmp_ok($two_aliased, '<', $with_two, 'Aliased typeglobs are smaller'); |
52 | |
53 | my $gp_size = $with_two - $two_aliased; |
54 | |
55 | $array[2] = \*KSSSH; |
56 | *KSSSH = \*PFLAP; |
57 | is(total_size(\@array), $with_one + 2 * $incremental_gv_size - 2 * $gp_size, |
58 | "3 aliased typeglobs are smaller, shared GP size is $gp_size"); |
59 | |
60 | my $copy = *PFLAP; |
61 | my $copy_gv_size = total_size($copy); |
62 | # GV copies point back to the real GV through GvEGV. They share the same GP |
638a265a |
63 | # and GvFILE. In 5.10 and later GvNAME is also shared. |
64 | my $shared_gvname = 0; |
65 | if ($] >= 5.010) { |
66 | # Calculate the size of the shared HEK: |
67 | my %h = (PFLAP => 0); |
68 | my $shared = (keys %h)[0]; |
69 | $shared_gvname = total_size($shared); |
70 | undef $shared; |
71 | $shared_gvname-= total_size($shared); |
72 | } |
73 | is($copy_gv_size, $real_gv_size + $incremental_gv_size - $gp_size |
74 | - $shared_gvname, 'GV copies point back to the real GV'); |
ae12fecd |
75 | } |
76 | |
88d3c90b |
77 | # As of blead commit b50b20584a1bbc1a, Implement new 'use 5.xxx' plan, |
78 | # use strict; will write to %^H. In turn, this causes the eval $code below |
79 | # to have compile with a pp_hintseval with a private copy of %^H in the |
80 | # optree. In turn, this private value is copied on op execution and put on |
81 | # the stack. The act of copying requires a hash iterator, and the *first* |
82 | # time the op is encountered its private HV doesn't have space for one, so |
83 | # it's expanded to hold one. Which happens after $cv_was_size is assigned to. |
84 | # Which matters, because it means that the total size of anything that can |
85 | # reach \&gv_grew will include this extra size. In this case, this means that |
86 | # if the code for generate_glob() is within gv_grew() [as it used to be], |
87 | # then the generated subroutine's CvOUTSIDE points to an anon sub whose |
88 | # CvOUTSIDE points to gv_grew(). Which means that the generated subroutine |
89 | # gets "bigger" simply as a side effect of the eval executing. |
90 | |
91 | # The solution is to put the eval that creates the subroutine into a different |
92 | # scope, so that its outside pointer chain doesn't include gv_grew(). Hence |
93 | # it's now broken out into generate_glob(): |
94 | |
95 | sub generate_glob { |
96 | my ($sub, $glob) = @_; |
ae12fecd |
97 | # unthreaded, this gives us a way of getting to sv_size() from one of the |
98 | # other *_size() functions, with a GV that has nothing allocated from its |
99 | # GP: |
100 | eval "sub $sub { *$glob }; 1" or die $@; |
88d3c90b |
101 | } |
102 | |
103 | sub gv_grew { |
104 | my ($sub, $glob, $code, $type) = @_; |
105 | generate_glob($sub, $glob); |
ae12fecd |
106 | # Assigning to IoFMT_GV() also provides this, threaded and unthreaded: |
107 | $~ = $glob; |
108 | |
109 | is(do {no strict 'refs'; *{$glob}{$type}}, undef, "No reference for $type") |
110 | unless $type eq 'SCALAR'; |
111 | my $cv_was_size = size(do {no strict 'refs'; \&$sub}); |
112 | my $gv_was_size = size(do {no strict 'refs'; *$glob}); |
113 | my $gv_was_total_size = total_size(do {no strict 'refs'; *$glob}); |
114 | my $io_was_size = size(*STDOUT{IO}); |
115 | |
116 | eval $code or die "For $type, can't execute q{$code}: $@"; |
117 | |
118 | my $new_thing = do {no strict 'refs'; *{$glob}{$type}}; |
119 | my $new_thing_size = size($new_thing); |
120 | |
121 | my $cv_now_size = size(do {no strict 'refs'; \&$sub}); |
122 | my $gv_now_size = size(do {no strict 'refs'; *$glob}); |
123 | my $gv_now_total_size = total_size(do {no strict 'refs'; *$glob}); |
124 | my $io_now_size = size(*STDOUT{IO}); |
125 | |
126 | # These run string evals with the source file synthesised based on caller |
127 | # source name, which means that %:: changes, which then peturbs sizes of |
128 | # anything that can reach them. So calculate and record the sizes before |
129 | # testing anything. |
130 | isnt($new_thing, undef, "Created a reference for $type"); |
131 | cmp_ok($new_thing_size, '>', 0, "For $type, new item has a size"); |
132 | |
133 | is($cv_now_size, $cv_was_size, |
ce5e7c21 |
134 | "Under ithreads, the optree doesn't directly close onto a GV, so CVs won't change size") |
135 | if $Config{useithreads}; |
ae12fecd |
136 | if ($] < 5.010 && $type eq 'SCALAR') { |
137 | is($cv_now_size, $cv_was_size, "CV doesn't grow as GV has SCALAR") |
ce5e7c21 |
138 | unless $Config{useithreads}; |
ae12fecd |
139 | is($io_now_size, $io_was_size, "IO doesn't grow as GV has SCALAR"); |
140 | is($gv_now_size, $gv_was_size, 'GV size unchanged as GV has SCALAR'); |
ae12fecd |
141 | is($gv_now_total_size, $gv_was_total_size, |
142 | 'GV total size unchanged as GV has SCALAR'); |
143 | } elsif ($type eq 'CODE' || $type eq 'FORMAT') { |
144 | # CV like things (effectively) close back over their typeglob, so its |
145 | # hard to just get the size of the CV. |
146 | cmp_ok($cv_now_size, '>', $cv_was_size, "CV grew for $type") |
ce5e7c21 |
147 | unless $Config{useithreads}; |
ae12fecd |
148 | cmp_ok($io_now_size, '>', $io_was_size, "IO grew for $type"); |
149 | # Assigning CVs and FORMATs to typeglobs causes the typeglob to get |
150 | # weak reference magic |
151 | cmp_ok($gv_now_size, '>', $gv_was_size, "GV size grew for $type"); |
152 | cmp_ok($gv_now_total_size, '>', $gv_was_total_size, |
153 | "GV total size grew for $type"); |
154 | } else { |
155 | is($cv_now_size, $cv_was_size + $new_thing_size, |
156 | "CV grew by expected amount for $type") |
ce5e7c21 |
157 | unless $Config{useithreads}; |
ae12fecd |
158 | is($io_now_size, $io_was_size + $new_thing_size, |
159 | "IO total_size grew by expected amount for $type"); |
160 | is($gv_now_size, $gv_was_size + $new_thing_size, |
161 | "GV size grew by expected amount for $type"); |
ae12fecd |
162 | is($gv_now_total_size, $gv_was_total_size + $new_thing_size, |
163 | "GV total_size grew by expected amount for $type"); |
164 | } |
165 | } |
166 | |
167 | gv_grew('glipp', 'zok', 'no strict "vars"; $zok = undef; 1', 'SCALAR'); |
168 | gv_grew('bang', 'boff', 'no strict "vars"; @boff = (); 1', 'ARRAY'); |
169 | gv_grew('clange', 'sock', 'no strict "vars"; %sock = (); 1', 'HASH'); |
d6158a76 |
170 | SKIP: { |
171 | skip("Can't create FORMAT references prior to 5.8.0", 7) if $] < 5.008; |
d3b8a135 |
172 | local $Devel::Memory::warn = 0; |
ae12fecd |
173 | gv_grew('biff', 'zapeth', "format zapeth =\n.\n1", 'FORMAT'); |
174 | } |
175 | gv_grew('crunch_eth', 'awkkkkkk', 'sub awkkkkkk {}; 1', 'CODE'); |
176 | |
d3b8a135 |
177 | # Devel::Memory isn't even tracking PVIOs from GVs (yet) |
ae12fecd |
178 | # gv_grew('kapow', 'thwape', 'opendir *thwape, "."', 'IO'); |
179 | |
180 | is($warn_count, undef, 'No warnings emitted'); |