[svn:parrot] r40836 - trunk/t/op
dukeleto at svn.parrot.org
dukeleto at svn.parrot.org
Fri Aug 28 04:54:49 UTC 2009
Author: dukeleto
Date: Fri Aug 28 04:54:47 2009
New Revision: 40836
URL: https://trac.parrot.org/parrot/changeset/40836
Log:
[TT #950][t] Convert t/op/gc.t to PIR, jrtayloriv++
Modified:
trunk/t/op/gc.t
Modified: trunk/t/op/gc.t
==============================================================================
--- trunk/t/op/gc.t Thu Aug 27 23:46:47 2009 (r40835)
+++ trunk/t/op/gc.t Fri Aug 28 04:54:47 2009 (r40836)
@@ -1,20 +1,14 @@
-#!perl
+#! parrot
# Copyright (C) 2001-2009, Parrot Foundation.
-# $Id$
-
-use strict;
-use warnings;
-use lib qw( . lib ../lib ../../lib );
-use Test::More;
-use Parrot::Test tests => 18;
+# $Id: string.t 40481 2009-08-11 06:09:35Z dukeleto $
=head1 NAME
-t/op/gc.t - Garbage Collection
+t/op/gc.t - Garbage collection
=head1 SYNOPSIS
- % prove t/op/gc.t
+ % prove t/op/gc.t
=head1 DESCRIPTION
@@ -23,117 +17,129 @@
=cut
-pir_output_is( <<'CODE', '1', "sweep 1" );
.include 'interpinfo.pasm'
+
.sub main :main
- $I1 = interpinfo .INTERPINFO_GC_MARK_RUNS # How many GC mark runs have we done already?
- sweep 1
- $I2 = interpinfo .INTERPINFO_GC_MARK_RUNS # Should be one more now
- $I3 = $I2 - $I1
- print $I3
+ .include 'test_more.pir'
+ plan(140)
+
+ sweep_1()
+ sweep_0()
+ sweep_0_need_destroy_obj()
+ sweep_0_need_destroy_destroy_obj()
+ collect_count()
+ collect_toggle()
+ collect_toggle_nested()
+ vanishing_singleton_PMC()
+ vanishing_ret_continuation()
+ regsave_marked()
+ recursion_and_exceptions()
+ write_barrier_1()
+ write_barrier_2()
+ addr_registry_1()
+ addr_registry_2_int()
+ addr_registry_2_str()
+ pmc_proxy_obj_mark()
+ coro_context_ret_continuation()
+ # END_OF_TESTS
+
.end
-CODE
-pir_output_is( <<'CODE', '0', "sweep 0" );
-.include 'interpinfo.pasm'
-.sub main :main
- $I1 = interpinfo .INTERPINFO_GC_MARK_RUNS # How many GC mark runs have we done already?
- sweep 0
- $I2 = interpinfo .INTERPINFO_GC_MARK_RUNS # Should be same
- $I3 = $I2 - $I1
- print $I3
-.end
-CODE
-
-pasm_output_is( <<'CODE', '1', "sweep 0, with object that need destroy" );
- new P0, 'Undef'
- interpinfo I1, 2 # How many GC mark runs have we done already?
- needs_destroy P0
- sweep 0
- interpinfo I2, 2 # Should be one more now
- sub I3, I2, I1
- print I3
- end
-CODE
-
-pasm_output_is( <<'CODE', '10', "sweep 0, with object that need destroy/destroy" );
- new P0, 'Undef'
- needs_destroy P0
- interpinfo I1, 2 # How many GC mark runs have we done already?
- new P0, 'Undef' # kill object
- sweep 0
- interpinfo I2, 2 # Should be one more now
- sub I3, I2, I1
- sweep 0
- interpinfo I4, 2 # Should be same as last
- sub I5, I4, I2
- print I3 # These create PMCs that need early GC, so we need
- print I5 # to put them after the second sweep op.
- end
-CODE
+.sub sweep_1
+ $I1 = interpinfo .INTERPINFO_GC_MARK_RUNS # How many GC mark runs have we done already?
+ sweep 1
+ $I2 = interpinfo .INTERPINFO_GC_MARK_RUNS # Should be one more now
+ $I3 = $I2 - $I1
+ is($I3,1)
+.end
-pir_output_is( <<'CODE', '1', "collect" );
-.include 'interpinfo.pasm'
-.sub main :main
- $I1 = interpinfo .INTERPINFO_GC_COLLECT_RUNS # How many garbage collections have we done already?
- collect
- $I2 = interpinfo .INTERPINFO_GC_COLLECT_RUNS # Should be one more now
- $I3 = $I2 - $I1
- print $I3
-.end
-CODE
-
-pasm_output_is( <<'CODE', <<'OUTPUT', "collectoff/on" );
- interpinfo I1, 3
- collectoff
- collect
- interpinfo I2, 3
- sub I3, I2, I1
- print I3
- print "\n"
-
- collecton
- collect
- interpinfo I4, 3
- sub I6, I4, I2
- print I6
- print "\n"
-
- end
-CODE
-0
-1
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', "Nested collectoff/collecton" );
- interpinfo I1, 3
- collectoff
- collectoff
- collecton
- collect # This shouldn't do anything... #'
- interpinfo I2, 3
- sub I3, I2, I1
- print I3
- print "\n"
-
- collecton
- collect # ... but this should
- interpinfo I4, 3
- sub I6, I4, I2
- print I6
- print "\n"
-
- end
-CODE
-0
-1
-OUTPUT
-pir_output_is( <<'CODE', <<OUTPUT, "vanishing singleton PMC" );
-.sub main :main
+.sub sweep_0
+ $I1 = interpinfo .INTERPINFO_GC_MARK_RUNS # How many GC mark runs have we done already?
+ sweep 0
+ $I2 = interpinfo .INTERPINFO_GC_MARK_RUNS # Should be same
+ $I3 = $I2 - $I1
+ is($I3,0)
+.end
+
+
+# sweep 0, with object that needs destroy/destroy
+.sub sweep_0_need_destroy_obj
+ $P0 = new 'Undef'
+ $I1 = interpinfo .INTERPINFO_GC_MARK_RUNS # How many GC mark runs have we done already?
+ needs_destroy $P0
+ sweep 0
+ $I2 = interpinfo .INTERPINFO_GC_MARK_RUNS # Should be one more now
+ $I3 = $I2 - $I1
+ is($I3,1)
+.end
+
+
+# sweep 0, with object that needs destroy/destroy
+.sub sweep_0_need_destroy_destroy_obj
+ $P0 = new 'Undef'
+ needs_destroy $P0
+ $I1 = interpinfo .INTERPINFO_GC_MARK_RUNS # How many GC mark runs have we done already?
+ $P0 = new 'Undef' #kill object
+ sweep 0
+ $I2 = interpinfo .INTERPINFO_GC_MARK_RUNS # Should be one more now
+ $I3 = $I2 - $I1
+ sweep 0
+ $I4 = interpinfo .INTERPINFO_GC_MARK_RUNS # Should be same as last
+ $I5 = $I4 - $I2
+ is($I3,1)
+ is($I5,0)
+.end
+
+
+.sub collect_count
+ $I1 = interpinfo .INTERPINFO_GC_COLLECT_RUNS # How many garbage collections have we done already?
+ collect
+ $I2 = interpinfo .INTERPINFO_GC_COLLECT_RUNS # Should be one more now
+ $I3 = $I2 - $I1
+ is($I3,1)
+.end
+
+
+.sub collect_toggle
+ $I1 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
+ collectoff
+ collect
+ $I2 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
+ $I3 = $I2 - $I1
+ is($I3,0)
+
+ collecton
+ collect
+ $I4 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
+ $I6 = $I4 - $I2
+ is($I6,1)
+.end
+
+
+.sub collect_toggle_nested
+ $I1 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
+ collectoff
+ collectoff
+ collecton
+ collect # This shouldn't do anything... #'
+ $I2 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
+ $I3 = $I2 - $I1
+ is($I3,0)
+
+ collecton
+ collect # ... but this should
+ $I4 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
+ $I6 = $I4 - $I2
+ is($I6,1)
+
+.end
+
+
+.sub vanishing_singleton_PMC
$P16 = new 'Env'
$P16['Foo'] = 'bar'
- $I16 = 100
+ $I16 = 100 #Why 100?
$I17 = 0
loop:
@@ -141,38 +147,27 @@
_rand()
$I17 += 1
if $I17 <= $I16 goto loop
- say "ok"
.end
.sub _rand
$P16 = new 'Env'
$P5 = $P16['Foo']
+ is($P5, 'bar')
if $P5 != 'bar' goto err
.return()
err:
- say "singleton destroyed .Env = ."
+ print "singleton destroyed .Env = ."
$P16 = new 'Env'
$S16 = typeof $P16
say $S16
.end
+# END: vanishing_singleton_PMC
-CODE
-ok
-OUTPUT
-
-pir_output_is( <<'CODE', <<OUTPUT, "vanishing return continuation in method calls" );
-.sub main :main
- .local pmc o, cl
- cl = newclass "Foo"
-
- new o, "Foo"
- print "ok\n"
- end
-.end
+# vanishing return continuation in method calls
.namespace ["Foo"]
.sub init :vtable :method
- print "init\n"
+ ok(1, "entered init()")
sweep 1
new $P6, 'String'
set $P6, "hi"
@@ -184,105 +179,81 @@
sweep 1
inc self
sweep 1
- print "back from _inc\n"
+ ok(1, "leaving do_inc")
.end
.sub __increment :method
- print "inc\n"
+ ok(1, "in __increment")
sweep 1
.end
-CODE
-init
-inc
-back from _inc
-ok
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "failing if regsave is not marked" );
- newclass P9, "Source"
- newclass P10, "Source::Buffer"
- new P12, "Source"
-
- set S20, P12
- print S20
- set S20, P12
- print S20
- end
+.namespace [ ]
+
+.sub vanishing_ret_continuation
+ .local pmc o, cl
+ cl = newclass 'Foo'
+ o = new 'Foo'
+ ok(1)
+.end
+# END: vanishing_return_continuation
+
+
+
+#Fail if regsave is not marked
.namespace ["Source"]
-.pcc_sub __get_string: # buffer
- get_params "0", P2
- getprop P12, "buffer", P2
+.sub get_string :method :vtable # buffer
+ $P4 = self
+ $P2 = getprop "buffer", $P4
sweep 1
- unless_null P12, buffer_ok
- new P12, "Source::Buffer"
- new P14, 'String'
- set P14, "hello\n"
- setprop P12, "buf", P14
- setprop P2, "buffer", P12
+ unless_null $P2, buffer_ok
+ $P2 = new "Source::Buffer"
+ $P3 = new "String"
+ $P3 = "hello"
+ $P2 = setprop "buf", $P3
+ $P4 = setprop "buffer", $P2
buffer_ok:
- set_returns "0", P12
- returncc
+ .return($P2)
+.end
.namespace ["Source::Buffer"]
-.pcc_sub __get_string:
- get_params "0", P2
+.sub get_string :method :vtable
+ $P4 = self
sweep 1
- getprop P12, "buf", P2
- set S16, P12
- set_returns "0", S16
- returncc
-CODE
-hello
-hello
-OUTPUT
+ $P2 = getprop "buf", $P4
+ $S0 = $P2
+ .return($S0)
+.end
-# this is a stripped down version of imcc/t/syn/pcc_16
-# s. also src/pmc/retcontinuation.pmc
-pasm_output_is( <<'CODE', <<OUTPUT, "coro context and invalid return continuations" );
-.pcc_sub main:
- .const 'Sub' P0 = "co1"
- set I20, 0
-l:
- get_results ''
- set_args ''
- invokecc P0
- inc I20
- lt I20, 3, l
- print "done\n"
- end
-.pcc_sub co1:
- get_params ''
- set P17, P1
-col:
- print "coro\n"
- sweep 1
- yield
- branch col
+.namespace [ ]
-CODE
-coro
-coro
-coro
-done
-OUTPUT
+.sub regsave_marked
+ $P0 = newclass "Source"
+ $P1 = newclass "Source::Buffer"
+ $P2 = new "Source"
-pir_output_is( <<'CODE', <<OUTPUT, "Recursion and exceptions" );
+ $S1 = $P2
+ is($S1, "hello")
-# this did segfault with GC_DEBUG
+ $S1 = $P2 #why are we doing this twice?
+ is($S1, "hello")
+.end
-.sub main :main
+# end regsave_marked()
+
+
+# Recursion and exceptions
+# NOTE: this did segfault with GC_DEBUG
+.sub recursion_and_exceptions
.local pmc n
$P0 = getinterp
$P0."recursion_limit"(10)
- newclass $P0, "b"
+ $P0 = newclass "b"
$P0 = new "b"
$P1 = new 'Integer'
$P1 = 0
n = $P0."b11"($P1)
- print "ok 1\n"
- print n
- print "\n"
+ ok(1)
+ is(n,8)
.end
.namespace ["b"]
.sub b11 :method
@@ -292,7 +263,8 @@
# store_lex -1, "n", n
n1 = new 'Integer'
n1 = n + 1
- push_eh catch
+ push_eh catch # we're going to catch an exception when recursion_depth
+ # is too large
n = self."b11"(n1)
# store_lex -1, "n", n
pop_eh
@@ -300,233 +272,176 @@
# n = find_lex "n"
.return(n)
.end
-CODE
-ok 1
-9
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "write barrier 1" );
- null I2
- set I3, 100
+.namespace [ ]
+
+# write barrier 1
+.sub write_barrier_1
+ null $I2
+ $I3 = 100
lp3:
- null I0
- set I1, 1000
- new P1, 'ResizablePMCArray'
+ null $I0
+ $I1 = 1000
+ $P1 = new 'ResizablePMCArray'
lp1:
- new P2, 'ResizablePMCArray'
- new P0, 'Integer'
- set P0, I0
- set P2[0], P0
- set P1[I0], P2
- if I0, not_0
- needs_destroy P0
- # force marking past P2[0]
+ $P2 = new 'ResizablePMCArray'
+ $P0 = new 'Integer'
+ $P0 = $I0
+ $P2[0] = $P0
+ $P1[$I0] = $P2
+ if $I0, not_0
+ needs_destroy $P0
+ # force marking past $P2[0]
sweep 0
not_0:
- new P3, 'Undef'
- new P4, 'Undef'
- inc I0
- lt I0, I1, lp1
+ $P3 = new 'Undef'
+ $P4 = new 'Undef'
+ inc $I0
+ lt $I0, $I1, lp1
- null I0
+ null $I0
# trace 1
lp2:
- set P2, P1[I0]
- set P2, P2[0]
- eq P2, I0, ok
+ $P2 = $P1[$I0]
+ $P2 = $P2[0]
+ eq $P2, $I0, ok
print "nok\n"
print "I0: "
- print I0
+ print $I0
print " P2: "
- print P2
+ print $P2
print " type: "
- typeof S0, P2
- print S0
+ $S0 = typeof $P2
+ print $S0
print " I2: "
- print I2
+ print $I2
print "\n"
exit 1
ok:
- inc I0
- lt I0, I1, lp2
- inc I2
- lt I2, I3, lp3
- print "ok\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "write barrier 2 - hash" );
- null I2
- set I3, 100
+ inc $I0
+ lt $I0, $I1, lp2
+ inc $I2
+ lt $I2, $I3, lp3
+ ok(1)
+.end
+
+
+# write barrier 2 - hash
+.sub write_barrier_2
+ null $I2
+ $I3 = 100
lp3:
- null I0
- set I1, 100
- new P1, 'Hash'
+ null $I0
+ $I1 = 100
+ $P1 = new 'Hash'
lp1:
- new P2, 'Hash'
- new P0, 'Integer'
- set P0, I0
- set S0, I0
- set P2["first"], P0
- set P1[S0], P2
- if I0, not_0
- new P0, 'Integer'
- needs_destroy P0
- null P0
+ $P2 = new 'Hash'
+ $P0 = new 'Integer'
+ $P0 = $I0
+ $S0 = $I0
+ $P2["first"] = $P0
+ $P1[$S0] = $P2
+ if $I0, not_0
+ $P0 = new 'Integer'
+ needs_destroy $P0
+ null $P0
# force full sweep
sweep 0
not_0:
- new P3, 'Undef'
- new P4, 'Undef'
- inc I0
- lt I0, I1, lp1
+ $P3 = new 'Undef'
+ $P4 = new 'Undef'
+ inc $I0
+ lt $I0, $I1, lp1
- null I0
+ null $I0
# trace 1
lp2:
- set S0, I0
- set P2, P1[S0]
- set P2, P2["first"]
- eq P2, I0, ok
+ $S0 = $I0
+ $P2 = $P1[$S0]
+ $P2 = $P2["first"]
+ eq $P2, $I0, ok
print "nok\n"
print "I0: "
- print I0
+ print $I0
print " P2: "
- print P2
+ print $P2
print " type: "
- typeof S0, P2
- print S0
+ $S0 = typeof $P2
+ print $S0
print " I2: "
- print I2
+ print $I2
print "\n"
exit 1
ok:
- inc I0
- lt I0, I1, lp2
- inc I2
- lt I2, I3, lp3
- print "ok\n"
- end
-CODE
-ok
-OUTPUT
-
-pir_output_is( <<'CODE', <<'OUTPUT', "verify pmc proxy object marking" );
-.sub main :main
- .local pmc cl, s, t
- cl = subclass "String", "X"
- addattribute cl, "o3"
- addattribute cl, "o4"
- s = new "X"
- $P0 = new 'String'
- $S0 = "ok" . " 3\n"
- $P0 = $S0
- setattribute s, "o3", $P0
- $P0 = new 'String'
- $S0 = "ok" . " 4\n"
- $P0 = $S0
- setattribute s, "o4", $P0
- null $P0
- null $S0
- null cl
- sweep 1
- s = "ok 1\n"
- print s
- .local int i
- i = 0
-lp:
- t = new "X"
- inc i
- if i < 1000 goto lp
- t = "ok 2\n"
- print s
- print t
- $P0 = getattribute s, "o3"
- print $P0
- $P0 = getattribute s, "o4"
- print $P0
+ inc $I0
+ lt $I0, $I1, lp2
+ inc $I2
+ lt $I2, $I3, lp3
+ ok(1)
.end
-CODE
-ok 1
-ok 1
-ok 2
-ok 3
-ok 4
-OUTPUT
-pir_output_is( <<'CODE', <<'OUTPUT', "AddrRegistry 1" );
-.sub main :main
+
+
+# AddrRegistry 1
+.sub addr_registry_1
.local pmc a, reg, nil
reg = new 'AddrRegistry'
a = new 'String'
null nil
$I0 = reg[a]
if $I0 == 0 goto ok1
- print "not "
+ notok(1)
ok1:
- print "ok 1\n"
+ ok(1, "ok 1")
reg[a] = nil
$I0 = reg[a]
if $I0 == 1 goto ok2
- print "not "
+ notok(1)
ok2:
- print "ok 2\n"
+ ok(1, "ok 2")
reg[a] = nil
$I0 = reg[a]
if $I0 == 2 goto ok3
- print "not "
+ notok(1)
ok3:
- print "ok 3\n"
-
+ ok(1, "ok 3")
delete reg[a]
$I0 = reg[a]
if $I0 == 1 goto ok4
- print "not "
+ notok(1)
ok4:
- print "ok 4\n"
+ ok(1, "ok 4")
delete reg[a]
$I0 = reg[a]
if $I0 == 0 goto ok5
- print "not "
+ notok(1)
ok5:
- print "ok 5\n"
+ ok(1, "ok 5")
.end
-CODE
-ok 1
-ok 2
-ok 3
-ok 4
-ok 5
-OUTPUT
-pir_output_is( <<'CODE', <<'OUTPUT', "AddrRegistry 2" );
-.sub main :main
+
+# AddrRegistry 2
+.sub addr_registry_2_int
.local pmc a, b, reg, nil
null nil
reg = new 'AddrRegistry'
a = new 'String'
b = new 'String'
$I0 = elements reg
- print $I0
+ is($I0, 0)
reg[a] = nil
$I0 = elements reg
- print $I0
+ is($I0, 1)
reg[a] = nil
$I0 = elements reg
- print $I0
+ is($I0, 1)
reg[b] = nil
$I0 = elements reg
- print $I0
- print "\n"
+ is($I0, 2)
.end
-CODE
-0112
-OUTPUT
-pir_output_is( <<'CODE', <<'OUTPUT', "AddrRegistry 2" );
-.sub main :main
+
+# AddrRegistry 2
+.sub addr_registry_2_str
.local pmc a, b, c, reg, nil, it
null nil
reg = new 'AddrRegistry'
@@ -551,12 +466,71 @@
done:
$P1.'sort'()
$S1 = join '', $P1
- print $S1
- print "\n"
+ is($S1, 'k1k2k3')
+.end
+
+# verify pmc proxy object marking
+.sub pmc_proxy_obj_mark
+ .local pmc cl, s, t
+ cl = subclass "String", "X"
+ addattribute cl, "o3"
+ addattribute cl, "o4"
+ s = new "X"
+ $P0 = new 'String'
+ $S0 = "ok" . " 3"
+ $P0 = $S0
+ setattribute s, "o3", $P0
+ $P0 = new 'String'
+ $S0 = "ok" . " 4"
+ $P0 = $S0
+ setattribute s, "o4", $P0
+ null $P0
+ null $S0
+ null cl
+ sweep 1
+ s = "ok 1"
+ is(s, "ok 1")
+ .local int i
+ i = 0
+lp:
+ t = new "X"
+ inc i
+ if i < 1000 goto lp
+ t = "ok 2"
+ is(s, "ok 1")
+ is(t, "ok 2")
+ $P0 = getattribute s, "o3"
+ is($P0, "ok 3")
+ $P0 = getattribute s, "o4"
+ is($P0, "ok 4")
+.end
+
+
+# coro context and invalid return continuations
+# this is a stripped down version of imcc/t/syn/pcc_16
+# s. also src/pmc/retcontinuation.pmc
+
+.sub coro_context_ret_continuation
+ .const 'Sub' $P0 = "co1"
+ $I20 = 0
+l:
+ get_results ''
+ set_args ''
+ invokecc $P0
+ inc $I20
+ lt $I20, 3, l
+ ok(1, "done\n")
+.end
+
+.sub co1
+ get_params ''
+ $P17 = $P1
+col:
+ ok(1, "coro\n")
+ sweep 1
+ yield
+ branch col
.end
-CODE
-k1k2k3
-OUTPUT
=head1 SEE ALSO
@@ -567,11 +541,9 @@
F<examples/benchmarks/primes2.c>,
F<examples/benchmarks/primes2.py>.
-=cut
-
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# fill-column: 100
# End:
-# vim: expandtab shiftwidth=4:
+# vim: expandtab shiftwidth=4 filetype=pir:
More information about the parrot-commits
mailing list