#! perl
# Copyright (C) 2006-2007, The Perl Foundation.
# $Id: /mirror/trunk/t/stm/queue.t 26279 2008-03-09T19:02:27.145248Z rblasch  $
use warnings;
use strict;
use lib qw( . lib ../lib ../../lib );
use Parrot::Test;

plan tests => 4;

=head1 NAME

t/stm/queue.t -- STM tests using a fixed-sized shared queue implementation

=head1 SYNOPSIS

    % prove t/stm/queue.t

=head1 DESCRIPTION

Uses a queue implemented using STM and a fixed-sized array to test the STM
implementation.

=cut

my $library = <<'CODE';

# STM fixed-sized, array-based queue.
# attributes:
#   head: index of next element to read
#   tail: index of next element to add
#   used: index of number of items used
#   array: fixed-sized array of STMVars.

.namespace ['STMQueue']

.sub __onload
    .local pmc class
    $P0 = get_class 'STMQueue'
    unless null $P0 goto done
    class = newclass 'STMQueue'
    addattribute class, 'head'
    addattribute class, 'tail'
    addattribute class, 'used'
    addattribute class, 'array'
    addattribute class, 'length'
    .return()
done:
.end

.sub init_pmc :vtable :method
    .param pmc args

    .local pmc tmpint
    .local pmc stmv

    tmpint = new 'Integer'
    tmpint = 0
    stmv = new 'STMVar', tmpint
    setattribute self, 'head', stmv
    stmv = new 'STMVar', tmpint
    setattribute self, 'used', stmv
    stmv = new 'STMVar', tmpint
    setattribute self, 'tail', stmv

    # Length is set during initialization
    .local int length
    $P0 = getattribute self, 'length'
    length = $P0

    # create array
    .local pmc array
    array = new 'Array'
    array = length
    .local int i
    i = 0
loop:
    stmv = new 'STMVar'
    array[i] = stmv
    inc i
    if i < length goto loop
    setattribute self, 'array', array
.end

.sub fetchHead :method
    .param int removep
    .param int blockp
    .local pmc i
    .local pmc tmp
    .local pmc used
    .local pmc ret
    .local int length
tx:
    stm_start
    used = getattribute self, 'used'
    used = used.'get_read'()
    if used != 0 goto have_items

    unless blockp goto no_block
    # FIXME: probably should throw exception instead
    # of going to no_block
    stm_wait no_block
    branch tx
have_items:
    tmp = getattribute self, 'head'
    i = tmp.'get_read'()
    tmp = getattribute self, 'array'
    tmp = tmp[i]
    ret = tmp.'get_read'()

    unless removep goto skip_remove
    tmp = getattribute self, 'head'
    $P0 = getattribute self, 'array'
    length = $P0
    i = clone i
    inc i
    i = i % length
    tmp.'set'(i)
    tmp = getattribute self, 'used'
    used = clone used
    used = used - 1
    tmp.'set'(used)
skip_remove:

    stm_commit tx
    branch normal_return

no_block:
    ret = new 'Undef'
    stm_abort
normal_return:
    .return (ret)
.end

.sub addTail :method
    .param pmc what
    .param int blockp

    .local pmc i
    .local pmc used
    .local int length
    .local int ret

    .local pmc tmp

    ret = 1
tx:
    stm_start

    i = getattribute self, 'tail'
    i = i.'get_read'()
    used = getattribute self, 'used'
    used = used.'get_update'()
    $P0 = getattribute self, 'array'
    length = $P0

    if used == length goto is_full

    inc used

    tmp = getattribute self, 'array'
    tmp = tmp[i]
    tmp.'set'(what)
    i = clone i
    inc i
    i = i % length

    tmp = getattribute self, 'tail'
    tmp.'set'(i)

    stm_commit tx
    branch do_ret

is_full:
    unless blockp goto no_block
    stm_wait error
    branch tx

no_block:
    stm_abort
error:
    ret = 0
do_ret:
    .return (ret)
.end

.sub clone :vtable :method
    .local pmc result
    .local pmc length

    $P0 = getattribute self, 'array'
    $I0 = $P0

    $P1 = get_class 'STMQueue'
    result = $P1.'new'('length' => $I0)

    $P0 = getattribute self, 'array'
    $P1 = clone $P0
    setattribute result, 'array', $P1
    $P0 = getattribute self, 'head'
    setattribute result, 'head', $P0
    $P0 = getattribute self, 'tail'
    setattribute result, 'tail', $P0
    $P0 = getattribute self, 'used'
    setattribute result, 'used', $P0
    .return (result)
.end

CODE

pir_output_is( $library . <<'CODE', <<'OUTPUT', "Single-threaded case" );
.sub main :main
    .local pmc queue

    $P0 = get_hll_global ['STMQueue'], '__onload'
    $P0()

    $P1 = get_class 'STMQueue'
    queue = $P1.'new'('length' => 10)


    queue.'addTail'(0, 0)
    queue.'addTail'(1, 0)
    queue.'addTail'(2, 0)
    queue.'addTail'(3, 0)
    $I0 = queue.'fetchHead'(1, 1)
    $I1 = queue.'fetchHead'(1, 1)
    $I2 = queue.'fetchHead'(1, 1)
    $I3 = queue.'fetchHead'(1, 1)

    print $I0
    print $I1
    print $I2
    print $I3
    print "\n"
.end

CODE
0123
OUTPUT

SKIP: {
    skip "These tests freeze up the whole interpreter", 2;
    pir_output_is( $library . <<'CODE', <<'OUTPUT', "Add in one thread, remove in the other" );
.const int MAX = 1000
.const int SIZE = 10

.sub adder
    .param pmc queue
    .local int i

    i = 0
loop:
    queue.'addTail'(i, 1)
    inc i
    if i < MAX goto loop
.end

.sub remover
    .param pmc queue
    .local int i
    .local int failed
    .local pmc got

    failed = 0
    i = 0
loop:
    got = queue.'fetchHead'(1, 1)
    if got != i goto not_okay
    inc i
    if i < MAX goto loop
    print "ok\n"
    .return ()
not_okay:
    print "not ok\n"
.end

.sub main :main
    .local pmc addThread
    .local pmc removeThread
    .local pmc queue
    .local pmc me

    .local pmc _add
    .local pmc _remove

    .local pmc copy

    .local int addThreadId
    .local int removeThreadId

    $P0 = get_hll_global ['STMQueue'], '__onload'
    $P0()

    _add = global "adder"
    _remove = global "remover"

    addThread = new 'ParrotThread'
    removeThread = new 'ParrotThread'
    $P0 = get_class 'STMQueue'
    queue = $P0.'new'('length' => SIZE)

    addThreadId = addThread
    removeThreadId = removeThread

    addThread.'run_clone'(_add, queue)
    removeThread.'run_clone'(_remove, queue)
    removeThread.'join'()
    addThread.'join'()
.end

CODE
ok
OUTPUT

    pir_output_is( $library . <<'CODE', <<'OUTPUT', "Test 2 + attempt to trigger thread death bugs" );

.sub adder
    .param pmc queue
    .local int i
    i = 0
loop:
    queue.'addTail'(i, 1)
    inc i
    if i < 10 goto loop
.end

.sub remover
    .param pmc queue
    .local int i
    .local int failed
    .local pmc got

    failed = 0
    i = 0
loop:
    got = queue.'fetchHead'(1, 1)
    if i < 9 goto no_sleep
    sleep 1 # sleep so other thread will die to trigger bug
no_sleep:
    print "got "
    print got
    print "\n"
    inc i
    if i < 10 goto loop
.end

.sub main :main
    .local pmc addThread
    .local pmc removeThread
    .local pmc queue
    .local pmc me

    .local pmc _add
    .local pmc _remove

    .local pmc copy

    .local int addThreadId
    .local int removeThreadId

    $P0 = get_hll_global ['STMQueue'], '__onload'
    $P0()

    _add = global "adder"
    _remove = global "remover"

    addThread = new 'ParrotThread'
    removeThread = new 'ParrotThread'
    $P0 = get_class 'STMQueue'
    queue = $P0.'new'('length' => 2)

    addThreadId = addThread
    removeThreadId = removeThread

    addThread.'run_clone'(_add, queue)
    removeThread.'run_clone'(_remove, queue)
    # This order is different.
    addThread.'join'()
    removeThread.'join'()
.end

CODE
got 0
got 1
got 2
got 3
got 4
got 5
got 6
got 7
got 8
got 9
OUTPUT

}

# This test is disabled because it is a known bug and sometimes
# passed and sometimes fails depending on timing.
SKIP: {
    skip "TODO test that fails intermittently", 1;
    pir_output_is(
        $library . <<'CODE', <<'OUTPUT', "Test 2 + detach + attempt to trigger thread death bugs" );

.sub adder
    .param pmc queue
    .local int i
    i = 0
loop:
    queue.'addTail'(i, 1)
    inc i
    if i < 10 goto loop
.end

.sub remover
    .param pmc queue
    .local int i
    .local int failed
    .local pmc got

    failed = 0
    i = 0
loop:
    got = queue.'fetchHead'(1, 1)
    if i < 9 goto no_sleep
    sleep 1 # sleep so other thread will die to trigger bug
no_sleep:
    print "got "
    print got
    print "\n"
    inc i
    if i < 10 goto loop
.end

.sub main :main
    .local pmc addThread
    .local pmc removeThread
    .local pmc queue
    .local pmc me

    .local pmc _add
    .local pmc _remove

    .local pmc copy

    .local int addThreadId
    .local int removeThreadId

    $P0 = get_hll_global ['STMQueue'], '__onload'
    $P0()

    _add = global "adder"
    _remove = global "remover"

    addThread = new 'ParrotThread'
    removeThread = new 'ParrotThread'
    $P0 = get_class 'STMQueue'
    queue = $P0.'new'('length' => 2)

    addThreadId = addThread
    removeThreadId = removeThread

    addThread.'run_clone'(_add, queue)
    removeThread.'run_clone'(_remove, queue)
    # Detach here, as of this writing preventing cleanup of
    # the thread's shared PMCs.
    addThread.'detach'()
    removeThread.'join'()
.end

CODE
got 0
got 1
got 2
got 3
got 4
got 5
got 6
got 7
got 8
got 9
OUTPUT
}

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 100
# End:
# vim: expandtab shiftwidth=4:
