1#! perl 2# Copyright (C) 2001-2015, Parrot Foundation. 3 4=head1 NAME 5 6t/stress/gc.t - Garbage Collection 7 8=head1 SYNOPSIS 9 10 % prove t/stress/gc.t 11 12=head1 DESCRIPTION 13 14Stress tests all garbage collectors. 15May require >10 min, but should reliably detect all GC assertions and segfaults. 16 17=cut 18 19use strict; 20use warnings; 21 22use lib qw(lib . ../lib ../../lib); 23my @gc; 24BEGIN { @gc = qw(gms ms2 ms inf); } 25use Parrot::Test tests => 6 * (1+@gc); 26use Test::More; 27use Parrot::PMC qw(%pmc_types); 28use Parrot::Config; 29use File::Spec; 30 31my $parrot = File::Spec->join( File::Spec->curdir(), 'parrot' . $PConfig{exe} ); 32my $JSONnqp = File::Spec->join( qw(compilers data_json JSON.nqp) ); 33my $opsc_03past = File::Spec->join( qw(t compilers opsc 03-past.t) ); 34 35sub gc_exit_test { 36 my ($cmd, $gc, $msg) = @_; 37 my $exit_code; 38 if ($exit_code = run_command($cmd, 39 CD => $PConfig{build_dir}, 40 STDOUT => "test_$$.out", 41 STDERR => "test_$$.err" )) 42 { 43 diag("'$cmd' failed with exit code $exit_code.") 44 } 45 else { 46 unlink("test_$$.out", "test_$$.err"); 47 } 48 TODO: 49 { 50 local $TODO = 'inf instability GH #1136' if $gc eq 'inf'; 51 is($exit_code, 0, $msg); 52 } 53} 54 55for my $gc (@gc, '--no-gc') { 56 57 # override the args 58 my $gc_arg = $gc eq '--no-gc' ? $gc : "--gc $gc"; 59 local $ENV{TEST_PROG_ARGS} = "-t11 $gc_arg --gc-debug --gc-nursery-size=0.0001 "; 60 my @TODO = $gc =~ /^ms/ ? ('todo' => 'ms instability GH #1143') : (); 61 @TODO = $gc eq 'inf' ? ('todo' => 'inf instability GH #1136') : @TODO; 62 63 pir_exit_code_is( <<'CODE', 0, "GC array stress $gc_arg", @TODO ); 64.sub 'main' :main 65 print "starting\n" 66 .local int arr_size 67 arr_size = 28 68 _bench( 'FixedFloatArray', arr_size ) 69 _bench( 'FixedIntegerArray', arr_size ) 70 _bench( 'FixedPMCArray', arr_size ) 71 _bench( 'FixedStringArray', arr_size ) 72 _bench( 'ResizableFloatArray', arr_size ) 73 _bench( 'ResizableIntegerArray', arr_size ) 74 _bench( 'ResizablePMCArray', arr_size ) 75 _bench( 'ResizableStringArray', arr_size ) 76 print "ending\n" 77.end 78.sub _bench 79 .param string arr_class 80 .param int arr_size 81 .local pmc arr_1, arr_2 82 arr_1 = new arr_class 83 arr_1 = arr_size 84 arr_2 = new arr_class 85 arr_2 = arr_size 86 .local num start_time 87 start_time = time 88 .local int x_index, value 89 x_index = 0 90 value = 1 91X_LOOP: 92 if x_index >= arr_size goto X_DONE 93 arr_1[x_index] = value 94 arr_2[x_index] = 0 95 inc x_index 96 inc value 97 goto X_LOOP 98X_DONE: 99 .local int max_index, z_index, y_index 100 max_index = arr_size - 1 101 y_index = 0 102Y_LOOP: 103 if y_index >= 100 goto Y_DONE 104 z_index = max_index 105Z_LOOP: 106 if z_index < 0 goto Z_DONE 107 set $I3, arr_2[z_index] 108 set $I4, arr_1[z_index] 109 add $I3, $I4 110 arr_2[z_index] = $I3 111 dec z_index 112 branch Z_LOOP 113Z_DONE: 114 inc y_index 115 branch Y_LOOP 116Y_DONE: 117 .local num start_time, end_time, span_time 118 end_time = time 119 span_time = end_time - start_time 120 .local string arr_type 121 arr_type = typeof arr_1 122 print arr_type 123 print ": " 124 print span_time 125 print "s\n" 126.end 127CODE 128 129 pir_exit_code_is( <<'CODE', 0, "GC rpa stress $gc_arg" ); 130.sub 'main' :main 131 .param pmc args 132 $I0 = 0 133 .local int N 134 N = args[1] 135 if N <= 0 goto loop 136 N = 10000 137 loop: 138 unless $I0 < N goto done 139 $P0 = new ['ResizablePMCArray'] 140 $P0 = 8 141 push $P0, $I0 # force realloc 142 inc $I0 143 goto loop 144 done: 145.end 146CODE 147 148 pir_exit_code_is( <<'CODE', 0, "GC subs stress $gc_arg" ); 149.sub 'main' :main 150 .param pmc args 151 152 $I0 = 0 153 .local int N 154 N = args[1] 155 if N <= 0 goto loop 156 N = 10000 157 158 loop: 159 unless $I0 < N goto done 160 'no-op'() 161 inc $I0 162 goto loop 163 done: 164.end 165 166.sub 'no-op' 167 noop 168.end 169CODE 170 171 pir_exit_code_is( <<'CODE', 0, "GC coros $gc_arg" ); 172.sub 'main' :main 173 .const 'Sub' $P99 = 'coro' 174 .local pmc three, four, five 175 three = clone $P99 176 four = clone $P99 177 five = clone $P99 178 three(3) 179 four(4) 180 five(5) 181 three(1) 182 push_eh ehandler 183 three(2) 184 four(1) 185 goto end 186 187 ehandler: 188 pop_eh 189 end: 190.end 191 192.sub '' :anon :subid('coro') 193 .param int x 194 .yield (x) 195 .yield (x) 196.end 197CODE 198 199 # And now a two big ones: involving lots of ops, strings and rpa's. 200 gc_exit_test 201 ("$parrot -D1 $gc_arg --gc-debug --gc-nursery-size=0.0001 -- parrot-nqp.pbc --target=pir $JSONnqp", 202 $gc, 203 "GC CallContext - GH #1159"); 204 205 gc_exit_test 206 ("$parrot -D1 $gc_arg --gc-debug --gc-nursery-size=0.001 -- parrot-nqp.pbc $opsc_03past", 207 $gc, 208 "GC opsc/03-past.t"); 209} 210 211# Local Variables: 212# mode: cperl 213# cperl-indent-level: 4 214# fill-column: 100 215# End: 216# vim: expandtab shiftwidth=4: 217