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