t/op/gc.t

   1 #!./parrot
   2 # Copyright (C) 2001-2010, Parrot Foundation.
   3 # $Id$
   4
   5 =head1 NAME
   6
   7 t/op/gc.t - Garbage collection
   8
   9 =head1 SYNOPSIS
  10
  11     % prove t/op/gc.t
  12
  13 =head1 DESCRIPTION
  14
  15 Tests garbage collection with the C<interpinfo> operation and various
  16 GC related bugs.
  17
  18 =cut
  19
  20 .include 'interpinfo.pasm'
  21
  22 .sub main :main
  23     .include 'test_more.pir'
  24     plan(140)
  25
  26     sweep_1()
  27     sweep_0()
  28     sweep_0_need_destroy_obj()
  29     sweep_0_need_destroy_destroy_obj()
  30     collect_count()
  31     collect_toggle()
  32     collect_toggle_nested()
  33     vanishing_singleton_PMC()
  34     vanishing_ret_continuation()
  35     regsave_marked()
  36     recursion_and_exceptions()
  37     write_barrier_1()
  38     write_barrier_2()
  39     addr_registry_1()
  40     addr_registry_2_int()
  41     addr_registry_2_str()
  42     pmc_proxy_obj_mark()
  43     coro_context_ret_continuation()
  44     # END_OF_TESTS
  45
  46 .end
  47
  48 .sub sweep_1
  49     $I1 = interpinfo .INTERPINFO_GC_MARK_RUNS  # How many GC mark runs have we done already?
  50     sweep 1
  51     $I2 = interpinfo .INTERPINFO_GC_MARK_RUNS  # Should be one more now
  52     $I3 = $I2 - $I1
  53     is($I3,1, "sweep_1")
  54 .end
  55
  56
  57 .sub sweep_0
  58     $I1 = interpinfo .INTERPINFO_GC_MARK_RUNS   # How many GC mark runs have we done already?
  59     sweep 0
  60     $I2 = interpinfo .INTERPINFO_GC_MARK_RUNS  # Should be same
  61     $I3 = $I2 - $I1
  62     is($I3,0, "sweep_0")
  63 .end
  64
  65
  66 # sweep 0, with object that needs destroy/destroy
  67 .sub sweep_0_need_destroy_obj
  68     $P0 = new 'Undef'
  69     $I1 = interpinfo .INTERPINFO_GC_MARK_RUNS   # How many GC mark runs have we done already?
  70     needs_destroy $P0
  71     sweep 0
  72     $I2 = interpinfo .INTERPINFO_GC_MARK_RUNS   # Should be one more now
  73     $I3 = $I2 - $I1
  74     is($I3,1, "sweep_0_need_destroy_obj")
  75 .end
  76
  77
  78 # sweep 0, with object that needs destroy/destroy
  79 .sub sweep_0_need_destroy_destroy_obj
  80     $P0 = new 'Undef'
  81     needs_destroy $P0
  82     $I1 = interpinfo .INTERPINFO_GC_MARK_RUNS   # How many GC mark runs have we done already?
  83     $P0 = new 'Undef'  #kill object
  84     sweep 0
  85     $I2 = interpinfo .INTERPINFO_GC_MARK_RUNS   # Should be one more now
  86     $I3 = $I2 - $I1
  87     sweep 0
  88     $I4 = interpinfo .INTERPINFO_GC_MARK_RUNS   # Should be same as last
  89     $I5 = $I4 - $I2
  90     is($I3,1, "sweep_0_need_destroy_destroy_obj")
  91     is($I5,0, "sweep_0_need_destroy_destroy_obj")
  92 .end
  93
  94
  95 .sub collect_count
  96     $I1 = interpinfo .INTERPINFO_GC_COLLECT_RUNS   # How many garbage collections have we done already?
  97     collect
  98     $I2 = interpinfo .INTERPINFO_GC_COLLECT_RUNS  # Should be one more now
  99     $I3 = $I2 - $I1
 100     is($I3,1, "collect_count")
 101 .end
 102
 103
 104 .sub collect_toggle
 105     $I1 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
 106     collectoff
 107     collect
 108     $I2 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
 109     $I3 = $I2 - $I1
 110     is($I3,0, "collect_toggle")
 111
 112     collecton
 113     collect
 114     $I4 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
 115     $I6 = $I4 - $I2
 116     is($I6,1, "collect_toggle")
 117 .end
 118
 119
 120 .sub collect_toggle_nested
 121     $I1 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
 122     collectoff
 123     collectoff
 124     collecton
 125     collect           # This shouldn't do anything...    #'
 126     $I2 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
 127     $I3 = $I2 - $I1
 128     is($I3,0, "collect_toggle_nested")
 129
 130     collecton
 131     collect           # ... but this should
 132     $I4 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
 133     $I6 = $I4 - $I2
 134     is($I6,1, "collect_toggle_nested")
 135
 136 .end
 137
 138
 139 .sub vanishing_singleton_PMC
 140     $P16 = new 'Env'
 141     $P16['Foo'] = 'bar'
 142     $I16 = 100    #Why 100?
 143     $I17 = 0
 144
 145     loop:
 146         sweep 1
 147         _rand()
 148         $I17 += 1
 149         if $I17 <= $I16 goto loop
 150 .end
 151
 152 .sub _rand
 153     $P16 = new 'Env'
 154     $P5 = $P16['Foo']
 155     is($P5, 'bar', "_rand")
 156     if $P5 != 'bar' goto err
 157     .return()
 158     err:
 159         print "singleton destroyed .Env = ."
 160         $P16 = new 'Env'
 161         $S16 = typeof $P16
 162         say $S16
 163 .end
 164 # END: vanishing_singleton_PMC
 165
 166
 167 # vanishing return continuation in method calls
 168 .namespace ["Foo"]
 169 .sub init :vtable :method
 170     ok(1, "entered init()")
 171     sweep 1
 172     new $P6, 'String'
 173     set $P6, "hi"
 174     self."do_inc"()
 175     sweep 1
 176 .end
 177
 178 .sub do_inc :method
 179     sweep 1
 180     inc self
 181     sweep 1
 182     ok(1, "leaving do_inc")
 183 .end
 184
 185 .sub increment :vtable :method
 186     ok(1, "in __increment")
 187     sweep 1
 188 .end
 189 .namespace [ ]
 190
 191 .sub vanishing_ret_continuation
 192     .local pmc o, cl
 193     cl = newclass 'Foo'
 194     o = new 'Foo'
 195     ok(1, "end vanishing_return_continuation")
 196 .end
 197
 198 # END: vanishing_return_continuation
 199
 200
 201
 202 #Fail if regsave is not marked
 203 .namespace ['Source']
 204 .sub get_string :method :vtable # buffer
 205     $P4  = self
 206     $P2 = getprop "buffer", $P4
 207     sweep 1
 208     unless_null $P2, buffer_ok
 209     $P2 = new ['Source'; 'Buffer']
 210     $P3 = new 'String'
 211     $P3 = 'hello'
 212     $P2 = setprop 'buf', $P3
 213     $P4  = setprop 'buffer', $P2
 214 buffer_ok:
 215     .return($P2)
 216 .end
 217
 218 .namespace ['Source'; 'Buffer']
 219 .sub get_string :method :vtable
 220     $P4 = self
 221     sweep 1
 222     $P2 = getprop "buf", $P4
 223     $S0 = $P2
 224     .return($S0)
 225 .end
 226
 227 .namespace [ ]
 228
 229 .sub regsave_marked
 230     $P0  = newclass 'Source'
 231     $P1 = newclass ['Source'; 'Buffer']
 232     $P2 = new 'Source'
 233
 234     $S1 = $P2
 235     is($S1, "hello")
 236
 237     $S1 = $P2        #why are we doing this twice?
 238     is($S1, "hello")
 239 .end
 240
 241 # end regsave_marked()
 242
 243
 244 # Recursion and exceptions
 245 # NOTE: this did segfault with GC_DEBUG
 246 .sub recursion_and_exceptions
 247     .local pmc n
 248     $P0 = getinterp
 249     $P0."recursion_limit"(10)
 250     $P0 = newclass "b"
 251     $P0 = new "b"
 252     $P1 = new 'Integer'
 253     $P1 = 0
 254     n = $P0."b11"($P1)
 255     ok(1, "recursion_and_exceptions")
 256     is(n,8, "recursion_and_exceptions")
 257 .end
 258 .namespace ["b"]
 259 .sub b11 :method
 260     .param pmc n
 261     .local pmc n1
 262     # new_pad -1
 263     # store_lex -1, "n", n
 264     n1 = new 'Integer'
 265     n1 = n + 1
 266     push_eh catch    # we're going to catch an exception when recursion_depth
 267                      # is too large
 268     n = self."b11"(n1)
 269     # store_lex -1, "n", n
 270     pop_eh
 271 catch:
 272     # n = find_lex "n"
 273     .return(n)
 274 .end
 275 .namespace [ ]
 276
 277 # write barrier 1
 278 .sub write_barrier_1
 279     null $I2
 280     $I3 = 100
 281 lp3:
 282     null $I0
 283     $I1 = 1000
 284     $P1 = new 'ResizablePMCArray'
 285 lp1:
 286     $P2 = new 'ResizablePMCArray'
 287     $P0 = new 'Integer'
 288     $P0 = $I0
 289     $P2[0] = $P0
 290     $P1[$I0] = $P2
 291     if $I0, not_0
 292     needs_destroy $P0
 293     # force marking past $P2[0]
 294     sweep 0
 295 not_0:
 296     $P3 = new 'Undef'
 297     $P4 = new 'Undef'
 298     inc $I0
 299     lt $I0, $I1, lp1
 300
 301     null $I0
 302     # trace 1
 303 lp2:
 304     $P2 = $P1[$I0]
 305     $P2 = $P2[0]
 306     eq $P2, $I0, ok
 307     print "nok\n"
 308     print "I0: "
 309     print $I0
 310     print " P2: "
 311     print $P2
 312     print " type: "
 313     $S0 = typeof $P2
 314     print $S0
 315     print " I2: "
 316     print $I2
 317     print "\n"
 318     exit 1
 319 ok:
 320     inc $I0
 321     lt $I0, $I1, lp2
 322     inc $I2
 323     lt $I2, $I3, lp3
 324     ok(1, "leaving write_barrier_1")
 325 .end
 326
 327
 328 # write barrier 2 - hash
 329 .sub write_barrier_2
 330     null $I2
 331     $I3 = 100
 332 lp3:
 333     null $I0
 334     $I1 = 100
 335     $P1 = new 'Hash'
 336 lp1:
 337     $P2 = new 'Hash'
 338     $P0 = new 'Integer'
 339     $P0 = $I0
 340     $S0 = $I0
 341     $P2["first"] = $P0
 342     $P1[$S0] = $P2
 343     if $I0, not_0
 344     $P0 = new 'Integer'
 345     needs_destroy $P0
 346     null $P0
 347     # force full sweep
 348     sweep 0
 349 not_0:
 350     $P3 = new 'Undef'
 351     $P4 = new 'Undef'
 352     inc $I0
 353     lt $I0, $I1, lp1
 354
 355     null $I0
 356     # trace 1
 357 lp2:
 358     $S0 = $I0
 359     $P2 = $P1[$S0]
 360     $P2 = $P2["first"]
 361     eq $P2, $I0, ok
 362     print "nok\n"
 363     print "I0: "
 364     print $I0
 365     print " P2: "
 366     print $P2
 367     print " type: "
 368     $S0 = typeof $P2
 369     print $S0
 370     print " I2: "
 371     print $I2
 372     print "\n"
 373     exit 1
 374 ok:
 375     inc $I0
 376     lt $I0, $I1, lp2
 377     inc $I2
 378     lt $I2, $I3, lp3
 379     ok(1, "leaving write_barrier_2")
 380 .end
 381
 382
 383
 384 # AddrRegistry 1
 385 .sub addr_registry_1
 386     .local pmc a, reg, nil
 387     reg = new 'AddrRegistry'
 388     a = new 'String'
 389     null nil
 390     $I0 = reg[a]
 391     if $I0 == 0 goto ok1
 392     notok(1)
 393 ok1:
 394     ok(1, "ok 1")
 395     reg[a] = nil
 396     $I0 = reg[a]
 397     if $I0 == 1 goto ok2
 398     notok(1)
 399 ok2:
 400     ok(1, "ok 2")
 401     reg[a] = nil
 402     $I0 = reg[a]
 403     if $I0 == 2 goto ok3
 404     notok(1)
 405 ok3:
 406     ok(1, "ok 3")
 407     delete reg[a]
 408     $I0 = reg[a]
 409     if $I0 == 1 goto ok4
 410     notok(1)
 411 ok4:
 412     ok(1, "ok 4")
 413     delete reg[a]
 414     $I0 = reg[a]
 415     if $I0 == 0 goto ok5
 416     notok(1)
 417 ok5:
 418     ok(1, "ok 5")
 419 .end
 420
 421
 422 # AddrRegistry 2
 423 .sub addr_registry_2_int
 424     .local pmc a, b, reg, nil
 425     null nil
 426     reg = new 'AddrRegistry'
 427     a = new 'String'
 428     b = new 'String'
 429     $I0 = elements reg
 430     is($I0, 0, "addr_registry_2_int")
 431     reg[a] = nil
 432     $I0 = elements reg
 433     is($I0, 1, "addr_registry_2_int")
 434     reg[a] = nil
 435     $I0 = elements reg
 436     is($I0, 1, "addr_registry_2_int")
 437     reg[b] = nil
 438     $I0 = elements reg
 439     is($I0, 2, "addr_registry_2_int")
 440 .end
 441
 442
 443 # AddrRegistry 2
 444 .sub addr_registry_2_str
 445     .local pmc a, b, c, reg, nil, it
 446     null nil
 447     reg = new 'AddrRegistry'
 448     a = new 'String'
 449     a = "k1"
 450     b = new 'String'
 451     b = "k2"
 452     c = new 'String'
 453     c = "k3"
 454     reg[a] = nil
 455     reg[b] = nil
 456     reg[c] = nil
 457
 458     $P1 = new ['ResizablePMCArray']
 459     it = iter reg
 460 loop:
 461     unless it goto done
 462     $P0 = shift it
 463     $S0 = $P0
 464     push $P1, $S0
 465     goto loop
 466 done:
 467     $P1.'sort'()
 468     $S1 = join '', $P1
 469     is($S1, 'k1k2k3')
 470 .end
 471
 472 # verify pmc proxy object marking
 473 .sub pmc_proxy_obj_mark
 474     .local pmc cl, s, t
 475     cl = subclass "String", "X"
 476     addattribute cl, "o3"
 477     addattribute cl, "o4"
 478     s = new "X"
 479     $P0 = new 'String'
 480     $S0 = "ok" . " 3"
 481     $P0 = $S0
 482     setattribute s, "o3", $P0
 483     $P0 = new 'String'
 484     $S0 = "ok" . " 4"
 485     $P0 = $S0
 486     setattribute s, "o4", $P0
 487     null $P0
 488     null $S0
 489     null cl
 490     sweep 1
 491     s = "ok 1"
 492     is(s, "ok 1")
 493     .local int i
 494     i = 0
 495 lp:
 496     t = new "X"
 497     inc i
 498     if i < 1000 goto lp
 499     t = "ok 2"
 500     is(s, "ok 1")
 501     is(t, "ok 2")
 502     $P0 = getattribute s, "o3"
 503     is($P0, "ok 3")
 504     $P0 = getattribute s, "o4"
 505     is($P0, "ok 4")
 506 .end
 507
 508
 509 # coro context and invalid return continuations
 510 # this is a stripped down version of imcc/t/syn/pcc_16
 511
 512 .sub coro_context_ret_continuation
 513     .const 'Sub' $P0 = "co1"
 514     $I20 = 0
 515 l:
 516     get_results ''
 517     set_args ''
 518     invokecc $P0
 519     inc $I20
 520     lt $I20, 3, l
 521     ok(1, "done\n")
 522 .end
 523
 524 .sub co1
 525     get_params ''
 526     $P17 = $P1
 527 col:
 528     ok(1, "coro\n")
 529     sweep 1
 530     yield
 531     branch col
 532 .end
 533
 534 =head1 SEE ALSO
 535
 536 F<examples/benchmarks/primes.c>,
 537 F<examples/benchmarks/primes.pasm>,
 538 F<examples/benchmarks/primes.pl>,
 539 F<examples/benchmarks/primes2_i.pasm>,
 540 F<examples/benchmarks/primes2.c>,
 541 F<examples/benchmarks/primes2.py>.
 542
 543 # Local Variables:
 544 #   mode: pir
 545 #   fill-column: 100
 546 # End:
 547 # vim: expandtab shiftwidth=4 ft=pir: