t/stm/runtime.t

   1 #! perl
   2 # Copyright (C) 2006-2007, The Perl Foundation.
   3 # $Id$
   4
   5 use strict;
   6 use warnings;
   7 use lib qw( . lib ../lib ../../lib );
   8 use Test::More;
   9 use Parrot::Test;
  10 use Parrot::Config;
  11
  12 plan tests => 5;
  13
  14 =pod
  15
  16 =head1 NAME
  17
  18 t/stm/runtime.t -- STM Runtime library tests
  19
  20 =head1 DESCRIPTION
  21
  22 Tests STM.pir and, as a side effect, the underlying STM implementation.
  23 This tests its general functionality using an array-based queue implemtation
  24 modified to use it, and includes several tests designed to trigger all
  25 cases for choice() (which in turn requires STMLog work correctly).
  26
  27 =cut
  28
  29 my $choice_test = <<'CODE';
  30 .sub do_choice
  31     .param pmc values
  32     .lex 'values', values
  33
  34     .local pmc _choice_one
  35     .local pmc _choice_two
  36     .const .Sub choice_one = 'choice_one'
  37     .const .Sub choice_two = 'choice_two'
  38     _choice_one = newclosure choice_one
  39     _choice_two = newclosure choice_two
  40     .local pmc _choice
  41     _choice = get_hll_global ['STM'], 'choice'
  42     $I0 = _choice(_choice_one, _choice_two)
  43     .return ($I0)
  44 .end
  45
  46 .sub choice_one :outer(do_choice)
  47     .local pmc values
  48     values = find_lex 'values'
  49     .local pmc what
  50     what = values[0]
  51     what = what.'get_update'()
  52     if what == 1 goto need_retry
  53     what = 1
  54     .return (1)
  55 need_retry:
  56     .local pmc retry
  57     retry = get_hll_global ['STM'], 'retry'
  58     retry()
  59 .end
  60
  61 .sub choice_two :outer(do_choice)
  62     .local pmc values
  63     values = find_lex 'values'
  64     .local pmc what
  65     .local pmc the_value
  66     what = values[1]
  67     the_value = what.'get_read'()
  68     if the_value == 1 goto need_retry
  69     the_value = new 'Integer'
  70     the_value = 1
  71     what.'set'(the_value)
  72     .return (2)
  73 need_retry:
  74     .local pmc retry
  75     retry = get_hll_global ['STM'], 'retry'
  76     retry()
  77 .end
  78
  79 CODE
  80
  81 # test 1
  82 pir_output_is( $choice_test . <<'CODE', <<'OUTPUT', "choice (one thread)" );
  83 .sub main :main
  84     .local pmc thread_one
  85     .local pmc thread_two
  86     thread_one = new 'ParrotThread'
  87     thread_two = new 'ParrotThread'
  88
  89     load_bytecode 'STM.pbc'
  90
  91     .local pmc values
  92     values = new 'FixedPMCArray'
  93     values = 2
  94     $P0 = new 'Integer'
  95     $P0 = 0
  96     $P0 = new 'STMVar', $P0
  97     values[0] = $P0
  98     $P0 = new 'Integer'
  99     $P0 = 0
 100     $P0 = new 'STMVar', $P0
 101     values[1] = $P0
 102     .local pmc _thread_main
 103     _thread_main = global 'do_choice'
 104
 105     $I0 = _thread_main(values)
 106     $I1 = _thread_main(values)
 107     $I2 = $I0 + $I1
 108     if $I2 != 3 goto fail
 109     if $I0 == 1 goto okay
 110     if $I1 == 1 goto okay
 111 fail:
 112     print 'not ok '
 113     print $I1
 114     print ', '
 115     print $I2
 116     print "\n"
 117     end
 118 okay:
 119     print "ok\n"
 120 .end
 121 CODE
 122 ok
 123 OUTPUT
 124
 125 # test 2
 126
 127 SKIP: {
 128     skip( "Intermittently failing everywhere", 2 );
 129
 130     pir_output_is( $choice_test . <<'CODE', <<'OUTPUT', "choice (multiple threads)" );
 131 .sub _wakeup_func
 132     .param pmc values
 133     .local pmc what
 134     sleep 1
 135     what = values[0]
 136     what.'set'(0)
 137 .end
 138
 139 .sub wakeup_func
 140     .param pmc values
 141     .local pmc transaction
 142     .local pmc real_sub
 143     transaction = get_hll_global ['STM'], 'transaction'
 144     real_sub = global '_wakeup_func'
 145     transaction(real_sub, values)
 146     .return (0)
 147 .end
 148
 149 .sub main :main
 150     .local pmc thread_one
 151     .local pmc thread_two
 152     .local pmc thread_three
 153     .local pmc wakeup_thread
 154     thread_one = new 'ParrotThread'
 155     thread_two = new 'ParrotThread'
 156     thread_three = new 'ParrotThread'
 157     wakeup_thread = new 'ParrotThread'
 158
 159     load_bytecode 'STM.pbc'
 160
 161     .local pmc values
 162     values = new 'FixedPMCArray'
 163     values = 2
 164     $P0 = new 'Integer'
 165     $P0 = 0
 166     $P0 = new 'STMVar', $P0
 167     values[0] = $P0
 168     $P0 = new 'Integer'
 169     $P0 = 0
 170     $P0 = new 'STMVar', $P0
 171     values[1] = $P0
 172     .local pmc _thread_main
 173     _thread_main = global 'do_choice'
 174     thread_one.'run_clone'(_thread_main, values)
 175     thread_two.'run_clone'(_thread_main, values)
 176     thread_three.'run_clone'(_thread_main, values)
 177     .local pmc _wakeup_thread_main
 178     _wakeup_thread_main = global 'wakeup_func'
 179     wakeup_thread.'run_clone'(_wakeup_thread_main, values)
 180     $I0 = thread_one.'join'()
 181     $I1 = thread_two.'join'()
 182     $I2 = thread_three.'join'()
 183     wakeup_thread.'join'()
 184
 185     if $I0 < 1 goto fail
 186     if $I1 < 1 goto fail
 187     if $I2 < 1 goto fail
 188     if $I0 > 2 goto fail
 189     if $I1 > 2 goto fail
 190     if $I2 > 2 goto fail
 191     .local int num_ones
 192     num_ones = 0
 193     if $I0 != 1 goto zero_two
 194     inc num_ones
 195 zero_two:
 196     if $I1 != 1 goto one_two
 197     inc num_ones
 198 one_two:
 199     if $I2 != 1 goto two_two
 200     inc num_ones
 201 two_two:
 202     if num_ones != 2 goto fail
 203     print "ok\n"
 204     end
 205 fail:
 206     print "not ok\n"
 207     print 'I0 = '
 208     print $I0
 209     print '; I1 = '
 210     print $I1
 211     print '; I2 = '
 212     print $I2
 213     print "\n"
 214 .end
 215 CODE
 216 ok
 217 OUTPUT
 218
 219     # test 3
 220     pir_output_is( <<'CODE', <<'OUTPUT', "choice doesn't clobber" );
 221 .sub make_clobber
 222     .param pmc value
 223     .param pmc setting
 224     .lex 'value', value
 225     .lex 'set_to', setting
 226     .const .Sub _clobber = '_clobber'
 227     $P0 = newclosure _clobber
 228     .return ($P0)
 229 .end
 230
 231 .sub _clobber :outer(make_clobber)
 232     .local pmc value
 233     .local pmc setting
 234     value = find_lex 'value'
 235     setting = find_lex 'set_to'
 236     value.'set'(setting)
 237     .local pmc retry
 238     retry = get_hll_global ['STM'], 'retry'
 239     retry()
 240 .end
 241
 242 .sub make_normal
 243     .param pmc value
 244     .lex 'value', value
 245     .const .Sub _normal = '_normal'
 246     $P0 = newclosure _normal
 247     .return ($P0)
 248 .end
 249
 250 .sub _normal :outer(make_normal)
 251     .local pmc value
 252     value = find_lex 'value'
 253     $P0 = value.'get_read'()
 254     if $P0 < 0 goto do_retry
 255     .return ()
 256 do_retry:
 257     .local pmc retry
 258     retry = get_hll_global ['STM'], 'retry'
 259     retry()
 260 .end
 261
 262 .sub _get
 263     .param pmc value
 264     .local pmc result
 265     result = value.'get_read'()
 266     .return (result)
 267 .end
 268
 269 .sub choice_thread
 270     .param pmc value
 271     $P0 = make_clobber(value, 10)
 272     $P1 = make_clobber(value, 20)
 273     $P2 = make_clobber(value, 30)
 274     $P3 = make_normal(value)
 275     $P4 = make_clobber(value, 40)
 276     .local pmc choice
 277     choice = get_hll_global ['STM'], 'choice'
 278     choice($P0, $P1, $P2, $P3, $P4)
 279 .end
 280
 281 .sub _wakeup_func
 282     .param pmc what
 283     what.'set'(0)
 284 .end
 285
 286 .sub wakeup_func
 287     .param pmc what
 288     .local pmc transaction
 289     .local pmc real_sub
 290     transaction = get_hll_global ['STM'], 'transaction'
 291     real_sub = global '_wakeup_func'
 292     transaction(real_sub, what)
 293     .return (0)
 294 .end
 295
 296 .sub main :main
 297     .local pmc tx
 298     .local pmc value
 299
 300     load_bytecode 'STM.pbc'
 301
 302     value = new 'Integer'
 303     value = -1
 304     value = new 'STMVar', value
 305
 306     .const .Sub wakeup = 'wakeup_func'
 307     .const .Sub choice = 'choice_thread'
 308     $P0 = new 'ParrotThread'
 309     $P1 = new 'ParrotThread'
 310     $P0.'run_clone'(choice, value)
 311     sleep 0.5
 312     $P1.'run_clone'(wakeup, value)
 313     $P0.'join'()
 314     $P1.'join'()
 315
 316     tx = get_hll_global ['STM'], 'transaction'
 317     .const .Sub _get = '_get'
 318     $P0 = tx(_get, value)
 319     if $P0 != 0 goto failed
 320     print "ok\n"
 321     end
 322 failed:
 323     print "NOT OKAY\n"
 324 .end
 325
 326 CODE
 327 ok
 328 OUTPUT
 329
 330 }    # skip x86_64
 331
 332 my $queue_test = <<'CODE';
 333 # attributes:
 334 #   head: index of next element to read
 335 #   tail: index of next element to add
 336 #   used: index of number of items used
 337 #   array: fixed-sized array of STMVars.
 338
 339 .namespace ['STMQueue']
 340
 341 .sub __onload
 342     .local pmc class
 343     $P0 = get_class 'STMQueue'
 344     unless null $P0 goto done
 345
 346     class = newclass 'STMQueue'
 347     addattribute class, 'head'
 348     addattribute class, 'tail'
 349     addattribute class, 'used'
 350     addattribute class, 'array'
 351     addattribute class, 'length'
 352   done:
 353     .return()
 354 .end
 355
 356 .sub init_pmc :vtable :method
 357     .param pmc args
 358
 359     .local pmc tmpint
 360     .local pmc stmv
 361
 362     tmpint = new 'Integer'
 363     tmpint = 0
 364     stmv = new 'STMVar', tmpint
 365     setattribute self, 'head', stmv
 366     stmv = new 'STMVar', tmpint
 367     setattribute self, 'used', stmv
 368     stmv = new 'STMVar', tmpint
 369     setattribute self, 'tail', stmv
 370
 371     # Length is set during initialization
 372     .local int length
 373     $P0 = getattribute self, 'length'
 374     length = $P0
 375
 376     # create array
 377     .local pmc array
 378     array = new 'Array'
 379     array = length
 380     .local int i
 381     i = 0
 382 loop:
 383     stmv = new 'STMVar'
 384     array[i] = stmv
 385     inc i
 386     if i < length goto loop
 387     setattribute self, 'array', array
 388 .end
 389
 390 .sub fetchHead :method
 391     .param int removep
 392     .param int blockp
 393
 394     $P0 = get_hll_global ['STM'], 'transaction'
 395     $P1 = global '_fetchHead'
 396     .return $P0($P1, self, removep, blockp)
 397 .end
 398
 399 .sub _fetchHead :method
 400     .param int removep
 401     .param int blockp
 402     .local pmc i
 403     .local pmc tmp
 404     .local pmc used
 405     .local pmc ret
 406     .local int length
 407     used = getattribute self, 'used'
 408     used = used.'get_read'()
 409     if used != 0 goto have_items
 410
 411     unless blockp goto no_block
 412     $P0 = get_hll_global ['STM'], 'retry'
 413     $P0()
 414
 415 have_items:
 416     tmp = getattribute self, 'head'
 417     i = tmp.'get_read'()
 418     tmp = getattribute self, 'array'
 419     tmp = tmp[i]
 420     ret = tmp.'get_read'()
 421
 422     unless removep goto skip_remove
 423     tmp = getattribute self, 'head'
 424     $P0 = getattribute self, 'array'
 425     length = $P0
 426     i = clone i
 427     inc i
 428     i = i % length
 429     tmp.'set'(i)
 430     tmp = getattribute self, 'used'
 431     used = clone used
 432     used = used - 1
 433     tmp.'set'(used)
 434 skip_remove:
 435     branch normal_return
 436
 437 no_block:
 438     ret = new 'Undef'
 439     $P0 = get_hll_global ['STM'], 'give_up'
 440     $P0()
 441 normal_return:
 442     .return (ret)
 443 .end
 444
 445 .sub addTail :method
 446     .param pmc what
 447     .param int blockp
 448
 449     $P0 = get_hll_global ['STM'], 'transaction'
 450     $P1 = global '_addTail'
 451     $P2 = $P0($P1, self, what, blockp)
 452     .return ($P2)
 453 .end
 454
 455 .sub _addTail :method
 456     .param pmc what
 457     .param int blockp
 458
 459     .local pmc i
 460     .local pmc used
 461     .local int length
 462     .local int ret
 463
 464     .local pmc tmp
 465
 466     ret = 1
 467     i = getattribute self, 'tail'
 468     i = i.'get_read'()
 469     used = getattribute self, 'used'
 470     used = used.'get_update'()
 471     $P0 = getattribute self, 'array'
 472     length = $P0
 473
 474     if used == length goto is_full
 475
 476     inc used
 477
 478     tmp = getattribute self, 'array'
 479     tmp = tmp[i]
 480     tmp.'set'(what)
 481     i = clone i
 482     inc i
 483     i = i % length
 484
 485     tmp = getattribute self, 'tail'
 486     tmp.'set'(i)
 487
 488     branch do_ret
 489
 490 is_full:
 491     unless blockp goto no_block
 492     $P0 = get_hll_global ['STM'], 'retry'
 493     $P0()
 494
 495 no_block:
 496     $P0 = get_hll_global ['STM'], 'give_up'
 497     $P0()
 498 error:
 499     ret = 0
 500 do_ret:
 501     .return (ret)
 502 .end
 503 CODE
 504
 505 TODO: {
 506         local $TODO = "sub bodies aren't properly cloned in threads, RT# 46519";
 507
 508 # test 4
 509 pir_output_is( $queue_test . <<'CODE', <<'OUTPUT', "queue adapted for the library" );
 510 .const int MAX = 5000
 511 .const int SIZE = 100
 512
 513 .sub adder
 514     .param pmc queue
 515     .local int i
 516
 517     i = 0
 518 loop:
 519     queue.'addTail'(i, 1)
 520     inc i
 521     if i < MAX goto loop
 522 .end
 523
 524 .sub remover
 525     .param pmc queue
 526     .local int i
 527     .local int failed
 528     .local pmc got
 529
 530     failed = 0
 531     i = 0
 532 loop:
 533     got = queue.'fetchHead'(1, 1)
 534     if got != i goto not_okay
 535     inc i
 536     if i < MAX goto loop
 537     print "ok\n"
 538     .return ()
 539 not_okay:
 540     print "not ok\n"
 541 .end
 542
 543 .sub main :main
 544     .local pmc addThread
 545     .local pmc removeThread
 546     .local pmc queue
 547
 548     .local pmc _add
 549     .local pmc _remove
 550
 551     load_bytecode 'STM.pbc'
 552
 553     $P0 = get_hll_global ['STMQueue'], '__onload'
 554     $P0()
 555
 556     _add = global "adder"
 557     _remove = global "remover"
 558
 559     addThread = new 'ParrotThread'
 560     removeThread = new 'ParrotThread'
 561     $P0 = get_class 'STMQueue'
 562     queue = $P0.'new'('length' => SIZE)
 563
 564     # addThreadId = addThread
 565     # removeThreadId = removeThread
 566
 567     addThread.'run_clone'(_add, queue)
 568     removeThread.'run_clone'(_remove, queue)
 569     removeThread.'join'()
 570     addThread.'join'()
 571 .end
 572 CODE
 573 ok
 574 OUTPUT
 575
 576 }
 577
 578 # test 5
 579 pir_output_is( $queue_test . <<'CODE', <<'OUTPUT', "queue (non-blocking; nested)" );
 580 .const int SIZE = 20
 581
 582 .sub _test
 583     .param pmc queue
 584
 585     $P0 = queue.'fetchHead'(1, 0)
 586     $I0 = defined $P0
 587     if $I0 == 1 goto fail
 588     queue.'addTail'(42, 1)
 589     $P0 = queue.'fetchHead'(0, 0)
 590     if $P0 != 42 goto fail
 591     $P0 = queue.'fetchHead'(1, 0)
 592     if $P0 != 42 goto fail
 593     $P0 = queue.'fetchHead'(1, 0)
 594     $I0 = defined $P0
 595     if $I0 == 1 goto fail
 596     .return (1)
 597 fail:
 598     .return (0)
 599 .end
 600
 601 .sub main :main
 602     .local pmc queue
 603
 604     load_bytecode 'STM.pbc'
 605
 606     $P0 = get_hll_global ['STMQueue'], '__onload'
 607     $P0()
 608
 609     $P0 = get_class 'STMQueue'
 610     queue = $P0.'new'('length' => SIZE)
 611
 612     $P0 = get_hll_global ['STM'], 'transaction'
 613     $P1 = global '_test'
 614     $P0($P1, queue)
 615
 616     print "ok\n"
 617     end
 618 fail:
 619     print "NOT OK\n"
 620 .end
 621 CODE
 622 ok
 623 OUTPUT
 624
 625 # Local Variables:
 626 #   mode: cperl
 627 #   cperl-indent-level: 4
 628 #   fill-column: 100
 629 # End:
 630 # vim: expandtab shiftwidth=4: