# threadkit-unit-test.pkg
#
# Unit tests for:
# src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg# Compiled by:
# src/lib/test/unit-tests.lib# Run by:
# src/lib/test/all-unit-tests.pkgstipulate
include package threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg #
package bx = binarytree_ximp; # binarytree_ximp is from src/lib/src/lib/thread-kit/src/core-thread-kit/binarytree-ximp.pkg package ci = mythryl_callable_c_library_interface; # mythryl_callable_c_library_interface is from src/lib/std/src/unsafe/mythryl-callable-c-library-interface.pkg package hth = hostthread; # hostthread is from src/lib/std/src/hostthread.pkg package io = io_bound_task_hostthreads; # io_bound_task_hostthreads is from src/lib/std/src/hostthread/io-bound-task-hostthreads.pkg package mps = microthread_preemptive_scheduler; # microthread_preemptive_scheduler is from src/lib/src/lib/thread-kit/src/core-thread-kit/microthread-preemptive-scheduler.pkg package psx = posixlib; # posixlib is from src/lib/std/src/psx/posixlib.pkg package tim = time; # time is from src/lib/std/time.pkgherein
package threadkit_unit_test {
# unit_test is from src/lib/src/unit-test.pkg # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg # mailslot is from src/lib/src/lib/thread-kit/src/core-thread-kit/mailslot.pkg # maildrop is from src/lib/src/lib/thread-kit/src/core-thread-kit/maildrop.pkg include package unit_test; # unit_test is from src/lib/src/unit-test.pkg nonfix my before;
my _ = log::note {. "threadkit_unit_test/AAA"; };
# start_up_thread_scheduler = tsc::start_up_thread_scheduler;
# my _ = printf "threadkit_unit_test/BBB\n";
# shut_down_thread_scheduler = tsc::shut_down_thread_scheduler;
# my _ = printf "threadkit_unit_test/CCC\n";
name = "src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit-unit-test.pkg tests";
fun test_basic_mailslot_functionality_a ()
=
{ # Send one message through a mailslot
# and verify that it is received:
slot = make_mailslot (): Mailslot(Int);
make_thread "threadkit_unit_test" {.
#
put_in_mailslot (slot, 13);
thread_exit { success => TRUE };
};
k = take_from_mailslot slot;
assert (k == 13);
};
fun test_basic_mailslot_functionality_b ()
=
{ # Send fifty messages through a mailslot
# and verify that they are received:
messages_to_transmit = 50;
#
Message = NONFINAL_MESSAGE Int
| FINAL_MESSAGE Int
;
slot = make_mailslot (): Mailslot(Message);
make_thread "threadkit_unit_test" {.
#
for (i = 1; i < messages_to_transmit; ++i) {
#
put_in_mailslot (slot, NONFINAL_MESSAGE i);
};
put_in_mailslot (slot, FINAL_MESSAGE messages_to_transmit);
thread_exit { success => TRUE };
};
messages_received
=
loop 0
where
fun loop i
=
{
log::note {. sprintf "%s\ttest_basic_mailslot_functionality_b/TAKELUP(%d)TOP" (mps::thread_scheduler_statestring ()) i; };
k = take_from_mailslot slot;
case k NONFINAL_MESSAGE n => log::note {. sprintf "%s\ttest_basic_mailslot_functionality_b/TAKELUP(%d) post-take NONFINAL_MESSAGE %d" (mps::thread_scheduler_statestring ()) i n; };
FINAL_MESSAGE n => log::note {. sprintf "%s\ttest_basic_mailslot_functionality_b/TAKELUP(%d) post-take FINAL_MESSAGE %d" (mps::thread_scheduler_statestring ()) i n; };
esac;
case k
# case (take_from_mailslot slot)
#
NONFINAL_MESSAGE n => loop (i+1);
FINAL_MESSAGE n => i+1;
esac;
};
end;
assert (messages_to_transmit == messages_received);
};
# Next step is to mutate this into a test of put_in_mailslot' and take_from_mailslot'
# instead of put_in_mailslot() and take_from_mailslot():
# (I think we should also increase the loopcount above
# once we strip out the printfs())
fun test_basic_mailslot_functionality_c ()
=
{ # Send fifty messages through a mailslot
# and verify that they are received:
messages_to_transmit = 50;
#
Message = NONFINAL_MESSAGE Int
| FINAL_MESSAGE Int
;
slot = make_mailslot (): Mailslot(Message);
make_thread "threadkit_unit_test" {.
#
for (i = 1; i < messages_to_transmit; ++i) {
#
block_until_mailop_fires (put_in_mailslot' (slot, NONFINAL_MESSAGE i));
};
block_until_mailop_fires (put_in_mailslot' (slot, FINAL_MESSAGE messages_to_transmit));
thread_exit { success => TRUE };
};
messages_received
=
loop 0
where
fun loop i
=
{
log::note {. sprintf "%s\ttest_basic_mailslot_functionality_c/TAKELUP(%d)TOP:" (mps::thread_scheduler_statestring ()) i; };
k = block_until_mailop_fires (take_from_mailslot' slot);
case k NONFINAL_MESSAGE n => log::note {. sprintf "%s\ttest_basic_mailslot_functionality_c/TAKELUP(%d) post-take: NONFINAL_MESSAGE %d" (mps::thread_scheduler_statestring ()) i n; };
FINAL_MESSAGE n => log::note {. sprintf "%s\ttest_basic_mailslot_functionality_c/TAKELUP(%d) post-take: FINAL_MESSAGE %d" (mps::thread_scheduler_statestring ()) i n; };
esac;
case k
# case (block_until_mailop_fires (take_from_mailslot' slot))
#
NONFINAL_MESSAGE n => loop (i+1);
FINAL_MESSAGE n => i+1;
esac;
};
end;
assert (messages_to_transmit == messages_received);
};
fun test_basic_maildrop_functionality ()
=
{
#
put_to_full_maildrop_should_fail ();
put_to_empty_maildrop_should_work ();
get_from_empty_maildrop_should_block ();
exercise_nonblocking_maildrop_peeks ();
exercise_blocking_maildrop_peeks ();
exercise_maildrop_value_swaps ();
}
where
fun put_to_full_maildrop_should_fail ()
=
{ drop = make_full_maildrop (): Maildrop(Void);
#
worked = REF FALSE;
put_in_maildrop (drop, ())
except
MAY_NOT_FILL_ALREADY_FULL_MAILDROP
=
worked := TRUE;
assert *worked;
};
fun put_to_empty_maildrop_should_work ()
=
{ drop = make_empty_maildrop (): Maildrop(Int);
#
worked = REF TRUE;
put_in_maildrop (drop, 17)
except
MAY_NOT_FILL_ALREADY_FULL_MAILDROP
=
worked := FALSE;
assert *worked;
assert (take_from_maildrop drop == 17);
};
fun get_from_empty_maildrop_should_block ()
=
{ drop1 = make_empty_maildrop (): Maildrop(Int);
drop2 = make_empty_maildrop (): Maildrop(Int);
#
make_thread "threadkit_unit_test 2" {.
#
put_in_maildrop (drop2, take_from_maildrop drop1 + 1);
thread_exit { success => TRUE };
};
put_in_maildrop (drop1, 23);
assert (take_from_maildrop drop2 == 24);
};
fun exercise_nonblocking_maildrop_peeks ()
=
{ drop = make_full_maildrop 29: Maildrop(Int);
#
assert (get_from_maildrop drop == 29); # Peek at maildrop without emptying it.
assert (the (nonblocking_get_from_maildrop drop) == 29);
assert (take_from_maildrop drop == 29); # Read and empty maildrop.
case (nonblocking_get_from_maildrop drop) # Peek to verify maildrop is now empty.
#
NULL => assert TRUE;
_ => assert FALSE;
esac;
};
fun exercise_blocking_maildrop_peeks ()
=
{
drop1 = make_empty_maildrop (): Maildrop(Int);
drop2 = make_empty_maildrop (): Maildrop(Int);
#
make_thread "threadkit_unit_test 3" {.
#
v0 = get_from_maildrop drop1;
v1 = v0 + 1;
put_in_maildrop (drop2, v1);
thread_exit { success => TRUE };
};
put_in_maildrop (drop1, 37);
assert (get_from_maildrop drop2 == 38);
};
fun exercise_maildrop_value_swaps ()
=
{ drop = make_full_maildrop (57): Maildrop( Int );
#
assert (maildrop_swap (drop, 59) == 57);
assert (take_from_maildrop drop == 59);
};
end;
fun test_basic_mailqueue_functionality ()
=
{
#
get_from_empty_mailqueue_should_block ();
queue_and_dequeue_50_values ();
test_take_all ();
test_take_all' ();
}
where
fun get_from_empty_mailqueue_should_block ()
=
{ q1 = make_mailqueue (get_current_microthread()): Mailqueue(Int);
q2 = make_mailqueue (get_current_microthread()): Mailqueue(Int);
#
make_thread "threadkit_unit_test 4" {.
#
put_in_mailqueue (q2, take_from_mailqueue q1 + 1);
thread_exit { success => TRUE };
};
put_in_mailqueue (q1, 93);
assert (take_from_mailqueue q2 == 94);
};
fun queue_and_dequeue_50_values ()
=
{ messages_to_transmit = 50;
#
Message = NONFINAL_MESSAGE | FINAL_MESSAGE;
q = make_mailqueue (get_current_microthread()): Mailqueue( Message );
for (i = 1; i < messages_to_transmit; ++i) {
#
put_in_mailqueue (q, NONFINAL_MESSAGE);
};
put_in_mailqueue (q, FINAL_MESSAGE);
messages_received
=
loop 0
where
fun loop i
=
case (take_from_mailqueue q)
#
NONFINAL_MESSAGE => loop (i+1);
FINAL_MESSAGE => (i+1);
esac;
end;
assert (messages_received == messages_to_transmit);
};
fun test_take_all ()
=
{ # This is a whitebox test intended to verify that
# ordering is correct when we have three items
# in the front of the queue and three in the back:
#
q = make_mailqueue (get_current_microthread()): Mailqueue( Int );
#
for (i = 1; i <= 4; ++i) {
#
put_in_mailqueue (q, i);
};
assert ((take_from_mailqueue q) == 1); # This will force the above values into the front half of queue.
for (i = 5; i <= 7; ++i) {
#
put_in_mailqueue (q, i); # These values will go on the back half of queue.
};
assert ((take_all_from_mailqueue q) == [ 2, 3, 4, 5, 6, 7 ]); # This call has to concatenate the front and back queue halves correctly.
};
fun test_take_all' ()
=
{ q = make_mailqueue (get_current_microthread()): Mailqueue( Int );
#
for (i = 1; i <= 4; ++i) {
#
put_in_mailqueue (q, i);
};
assert (take_from_mailqueue q == 1); # This will force the above values into the front half of queue.
for (i = 5; i <= 7; ++i) {
#
put_in_mailqueue (q, i); # These values will go on the back half of queue.
};
assert ((block_until_mailop_fires (take_all_from_mailqueue' q)) == [ 2, 3, 4, 5, 6, 7 ]); # This call has to concatenate the front and back queue halves correctly.
};
end;
fun test_basic_mailcaster_functionality ()
=
{
#
get_from_empty_mailcaster_should_block ();
queue_and_dequeue_50_values ();
}
where
fun get_from_empty_mailcaster_should_block ()
=
{ c1 = make_mailcaster (): Mailcaster(Int);
c2 = make_mailcaster (): Mailcaster(Int);
q1 = make_readqueue c1: Readqueue(Int);
q2 = make_readqueue c2: Readqueue(Int);
make_thread "threadkit_unit_test 5" {.
#
transmit (c2, receive q1 + 1);
thread_exit { success => TRUE };
};
transmit (c1, 93);
assert (receive q2 == 94);
};
fun queue_and_dequeue_50_values ()
=
{ messages_to_transmit = 50;
#
Message = NONFINAL_MESSAGE | FINAL_MESSAGE;
# Create a mailcaster and two readqueues on it:
c = make_mailcaster (): Mailcaster( Message );
q1 = make_readqueue c: Readqueue( Message );
q2 = make_readqueue c: Readqueue( Message );
# Write 50 messages into mailcaster:
#
for (i = 1; i < messages_to_transmit; ++i) {
#
transmit (c, NONFINAL_MESSAGE);
};
transmit (c, FINAL_MESSAGE);
# Read all 50 from first readqueue:
#
messages_received
=
loop 0
where
fun loop i
=
case (receive q1)
NONFINAL_MESSAGE => loop (i+1);
FINAL_MESSAGE => (i+1);
esac;
end;
assert (messages_received == messages_to_transmit);
# Read all 50 from second readqueue:
#
messages_received
=
loop 0
where
fun loop i
=
case (receive q2)
NONFINAL_MESSAGE => loop (i+1);
FINAL_MESSAGE => (i+1);
esac;
end;
assert (messages_received == messages_to_transmit);
};
end;
fun test_basic_thread_local_property_functionality ()
=
{
#
test_generic_thread_local_property_functionality ();
test_boolean_thread_local_property_functionality ();
}
where
fun test_generic_thread_local_property_functionality ()
=
{ prop = make_per_thread_property {. 0; };
#
Message = ONE(Int) | TWO(Int);
slot = make_mailslot (): Mailslot( Message );
make_thread "threadkit_unit_test 6" {.
#
prop.set 1;
put_in_mailslot (slot, ONE (prop.get ()));
};
make_thread "threadkit_unit_test 7" {.
#
prop.set 2;
put_in_mailslot (slot, TWO (prop.get ()));
};
case (take_from_mailslot slot)
#
ONE one => assert (one == 1);
TWO two => assert (two == 2);
esac;
case (take_from_mailslot slot)
#
ONE one => assert (one == 1);
TWO two => assert (two == 2);
esac;
};
fun test_boolean_thread_local_property_functionality ()
=
{ prop = make_boolean_per_thread_property ();
#
Message = TRUE_MESSAGE Bool
| FALSE_MESSAGE Bool
;
slot = make_mailslot (): Mailslot( Message );
make_thread "threadkit_unit_test 8" {.
#
prop.set TRUE;
put_in_mailslot (slot, TRUE_MESSAGE (prop.get ()));
};
make_thread "threadkit_unit_test 9" {.
#
prop.set FALSE;
put_in_mailslot (slot, FALSE_MESSAGE (prop.get ()));
};
case (take_from_mailslot slot)
#
TRUE_MESSAGE true_val => assert ( true_val == TRUE );
FALSE_MESSAGE false_val => assert (false_val == FALSE);
esac;
case (take_from_mailslot slot)
#
TRUE_MESSAGE true_val => assert ( true_val == TRUE );
FALSE_MESSAGE false_val => assert (false_val == FALSE);
esac;
};
end;
fun test_basic_timeout_functionality ()
=
{
#
test_sleep_for ();
test_sleep_until ();
}
where
now = tim::get_current_time_utc;
fun test_sleep_for ()
=
{
before = now ();
#
sleep_for 0.1;
after = now ();
elapsed_time = tim::(-) (after, before);
milliseconds = tim::to_milliseconds elapsed_time;
assert (milliseconds >= 100);
};
fun test_sleep_until ()
=
{
before = now ();
wakeup_time = tim::(+) (before, tim::from_milliseconds 100);
sleep_until wakeup_time;
after = now ();
assert (tim::(>=) (after, wakeup_time));
};
end;
fun test_basic_select_functionality ()
=
{
#
test_select_over_input_mailslots ();
test_select_over_input_maildrops ();
test_select_over_input_mailqueues ();
test_select_over_output_mailslots ();
test_select_over_timeout_mailops ();
}
where
fun test_select_over_input_mailslots ()
=
{
input_slot_1 = make_mailslot (): Mailslot(Int);
input_slot_2 = make_mailslot (): Mailslot(Int);
output_drop_1 = make_empty_maildrop (): Maildrop(Int);
output_drop_2 = make_empty_maildrop (): Maildrop(Int);
make_thread "threadkit_unit_test 10" {.
#
for (;;) {
#
do_one_mailop [
take_from_mailslot' input_slot_1 ==> {.
put_in_maildrop (output_drop_1, #value); },
take_from_mailslot' input_slot_2 ==> {.
put_in_maildrop (output_drop_2, #value); }
];
};
};
put_in_mailslot (input_slot_1, 13);
put_in_mailslot (input_slot_2, 17);
assert (take_from_maildrop output_drop_1 == 13);
assert (take_from_maildrop output_drop_2 == 17);
};
fun test_select_over_input_maildrops ()
=
{ input_drop_1 = make_empty_maildrop (): Maildrop(Int);
input_drop_2 = make_empty_maildrop (): Maildrop(Int);
output_drop_1 = make_empty_maildrop (): Maildrop(Int);
output_drop_2 = make_empty_maildrop (): Maildrop(Int);
make_thread "threadkit_unit_test 11" {.
#
for (;;) {
#
do_one_mailop [
take_from_maildrop' input_drop_1 ==> {.
put_in_maildrop (output_drop_1, #value); },
take_from_maildrop' input_drop_2 ==> {.
put_in_maildrop (output_drop_2, #value); }
];
};
};
put_in_maildrop (input_drop_1, 11);
put_in_maildrop (input_drop_2, 19);
assert (take_from_maildrop output_drop_1 == 11);
assert (take_from_maildrop output_drop_2 == 19);
};
fun test_select_over_input_mailqueues ()
=
{ input_queue_1 = make_mailqueue (get_current_microthread()): Mailqueue(Int);
input_queue_2 = make_mailqueue (get_current_microthread()): Mailqueue(Int);
output_drop_1 = make_empty_maildrop (): Maildrop(Int);
output_drop_2 = make_empty_maildrop (): Maildrop(Int);
make_thread "threadkit_unit_test 12" {.
#
for (;;) {
#
do_one_mailop [
take_from_mailqueue' input_queue_1 ==> {.
put_in_maildrop (output_drop_1, #value); },
take_from_mailqueue' input_queue_2 ==> {.
put_in_maildrop (output_drop_2, #value); }
];
};
};
put_in_mailqueue (input_queue_1, 1);
put_in_mailqueue (input_queue_2, 3);
assert (take_from_maildrop output_drop_1 == 1);
assert (take_from_maildrop output_drop_2 == 3);
};
fun test_select_over_output_mailslots ()
=
{ output_slot_1 = make_mailslot (): Mailslot(Int);
output_slot_2 = make_mailslot (): Mailslot(Int);
make_thread "threadkit_unit_test 13" {.
#
for (;;) {
#
do_one_mailop [
put_in_mailslot' (output_slot_1, 3) ==> {. (); },
put_in_mailslot' (output_slot_2, 5) ==> {. (); }
];
};
};
assert (take_from_mailslot output_slot_1 == 3);
assert (take_from_mailslot output_slot_2 == 5);
};
fun test_select_over_timeout_mailops ()
=
{ output_slot = make_mailslot (): Mailslot(Int);
make_thread "threadkit_unit_test 14" {.
#
do_one_mailop [
timeout_in' 0.100 ==> {. put_in_mailslot (output_slot, 100); },
timeout_in' 0.050 ==> {. put_in_mailslot (output_slot, 50); },
timeout_in' 0.010 ==> {. put_in_mailslot (output_slot, 10); }
];
do_one_mailop [
timeout_in' 0.100 ==> {. put_in_mailslot (output_slot, 100); },
timeout_in' 0.050 ==> {. put_in_mailslot (output_slot, 50); }
];
do_one_mailop [
timeout_in' 0.100 ==> {. put_in_mailslot (output_slot, 100); }
];
};
assert (take_from_mailslot output_slot == 10);
assert (take_from_mailslot output_slot == 50);
assert (take_from_mailslot output_slot == 100);
};
end;
fun test_basic_succeed_vs_fail_functionality ()
=
{
test_exit_state_of_thread_that_succeeded ();
test_exit_state_of_thread_that_failed ();
test_exit_state_of_thread_killed_by_exception ();
test_exit_state_of_task_that_succeeded ();
test_exit_state_of_task_that_failed ();
test_exit_state_of_task_killed_by_exception ();
test_exit_state_of_2_thread_task_that_succeeded ();
test_exit_state_of_2_thread_task_that_failed_a ();
test_exit_state_of_2_thread_task_that_failed_b ();
test_exit_state_of_2_thread_task_that_failed_c ();
test_exit_state_of_2_thread_task_killed_by_exception_a ();
test_exit_state_of_2_thread_task_killed_by_exception_b ();
test_exit_state_of_thread_killed_as_successful ();
test_exit_state_of_thread_killed_as_failure ();
}
where
fun test_exit_state_of_thread_that_succeeded ()
=
{
test_thread = make_thread "successful thread" {. thread_exit { success => TRUE }; };
thread_finished' = thread_done__mailop test_thread;
block_until_mailop_fires thread_finished';
assert (get_thread's_state test_thread == state::SUCCESS);
};
fun test_exit_state_of_thread_that_failed ()
=
{
test_thread = make_thread "unsuccessful thread" {. thread_exit { success => FALSE }; };
thread_finished' = thread_done__mailop test_thread;
block_until_mailop_fires thread_finished';
assert (get_thread's_state test_thread == state::FAILURE);
};
fun test_exit_state_of_thread_killed_by_exception ()
=
{
printf "\nThe following DIE exception is a test -- IGNORE IT: ";
test_thread = make_thread "exceptional thread" {. raise exception DIE "testing..."; };
thread_finished' = thread_done__mailop test_thread;
block_until_mailop_fires thread_finished';
assert (get_thread's_state test_thread == state::FAILURE_DUE_TO_UNCAUGHT_EXCEPTION);
};
fun test_exit_state_of_task_that_succeeded ()
=
{
test_task = make_task "successful task" [ ("successful thread", {. thread_exit { success => TRUE }; } ) ];
task_finished' = task_done__mailop test_task;
block_until_mailop_fires task_finished';
assert (get_task's_state test_task == state::SUCCESS);
};
fun test_exit_state_of_task_that_failed ()
=
{
test_task = make_task "unsuccessful task" [ ("unsuccessful thread", {. thread_exit { success => FALSE }; } ) ];
task_finished' = task_done__mailop test_task;
block_until_mailop_fires task_finished';
assert (get_task's_state test_task == state::FAILURE);
};
fun test_exit_state_of_task_killed_by_exception ()
=
{
printf "\nThe following DIE exception is a test -- IGNORE IT: ";
test_task = make_task "exceptional task" [ ("exceptional thread", {. raise exception DIE "testing..."; } ) ];
task_finished' = task_done__mailop test_task;
block_until_mailop_fires task_finished';
assert (get_task's_state test_task == state::FAILURE_DUE_TO_UNCAUGHT_EXCEPTION);
};
fun test_exit_state_of_2_thread_task_that_succeeded ()
=
{
test_task = make_task "successful task" [ ("successful thread", {. thread_exit { success => TRUE }; } ),
("successful thread", {. thread_exit { success => TRUE }; } )
];
task_finished' = task_done__mailop test_task;
block_until_mailop_fires task_finished';
assert (get_task's_state test_task == state::SUCCESS);
};
fun test_exit_state_of_2_thread_task_that_failed_a ()
=
{
test_task = make_task "unsuccessful task" [ ("unsuccessful thread", {. thread_exit { success => FALSE }; } ),
("unsuccessful thread", {. thread_exit { success => FALSE }; } )
];
task_finished' = task_done__mailop test_task;
block_until_mailop_fires task_finished';
assert (get_task's_state test_task == state::FAILURE);
};
fun test_exit_state_of_2_thread_task_that_failed_b ()
=
{
test_task = make_task "unsuccessful task" [ ("unsuccessful thread", {. thread_exit { success => FALSE }; } ),
("unsuccessful thread", {. thread_exit { success => TRUE }; } )
];
task_finished' = task_done__mailop test_task;
block_until_mailop_fires task_finished';
assert (get_task's_state test_task == state::FAILURE);
};
fun test_exit_state_of_2_thread_task_that_failed_c ()
=
{
test_task = make_task "unsuccessful task" [ ("unsuccessful thread", {. thread_exit { success => TRUE }; } ),
("unsuccessful thread", {. thread_exit { success => FALSE }; } )
];
task_finished' = task_done__mailop test_task;
block_until_mailop_fires task_finished';
assert (get_task's_state test_task == state::FAILURE);
};
fun test_exit_state_of_2_thread_task_killed_by_exception_a ()
=
{
printf "\nThe following DIE exception is a test -- IGNORE IT: ";
test_task = make_task "exceptional task" [ ("exceptional thread", {. raise exception DIE "testing..."; } ),
("successful thread", {. thread_exit { success => TRUE }; } )
];
task_finished' = task_done__mailop test_task;
block_until_mailop_fires task_finished';
assert (get_task's_state test_task == state::FAILURE_DUE_TO_UNCAUGHT_EXCEPTION);
};
fun test_exit_state_of_2_thread_task_killed_by_exception_b ()
=
{
printf "\nThe following DIE exception is a test -- IGNORE IT: ";
test_task = make_task "exceptional task" [ ("successful thread", {. thread_exit { success => TRUE }; } ),
("exceptional thread", {. raise exception DIE "testing..."; } )
];
task_finished' = task_done__mailop test_task;
block_until_mailop_fires task_finished';
assert (get_task's_state test_task == state::FAILURE_DUE_TO_UNCAUGHT_EXCEPTION);
};
fun test_exit_state_of_thread_killed_as_successful ()
=
{
test_thread = make_thread "infinite-loop thread" {. fun loop () = loop (); loop (); };
thread_finished' = thread_done__mailop test_thread;
yield ();
yield ();
yield ();
assert (get_thread's_state test_thread == state::ALIVE);
kill_thread { thread => test_thread, success => TRUE };
block_until_mailop_fires thread_finished';
assert (get_thread's_state test_thread == state::SUCCESS);
};
fun test_exit_state_of_thread_killed_as_failure ()
=
{
test_thread = make_thread "infinite-loop thread" {. loop () where fun loop () = loop (); end; };
thread_finished' = thread_done__mailop test_thread;
yield ();
yield ();
yield ();
assert (get_thread's_state test_thread == state::ALIVE);
kill_thread { thread => test_thread, success => FALSE };
block_until_mailop_fires thread_finished';
assert (get_thread's_state test_thread == state::FAILURE);
};
end;
fun test_basic_preemptive_scheduling_fairness ()
=
{
# Run two CPU-bound-loop microthreads for one second
# and verify that they both get a fair share of cycles:
mps::alarm_handler_calls := 0;
mps::alarm_handler_calls_with__uninterruptible_scope_mutex__set := 0;
mps::alarm_handler_calls_with__microthread_switch_lock__set := 0;
stipulate
dummy = REF 0;
herein
fun worker_thread counter
=
{ for (i = 100000; i > 0; --i) {
if (i & 1 == 0) dummy := *dummy + 1; # This is just intended to discourage the compiler from optimizing the loop away.
else dummy := *dummy - 1;
fi;
};
counter := *counter + 1; # Track 'work' done by microthread.
worker_thread counter;
};
end;
# Counters to track 'work' done by the two microthreads:
#
counter1 = REF 0;
counter2 = REF 0;
fun initialize__timeslicing__task ()
=
{ make_thread "worker thread" {. worker_thread counter1; };
make_thread "worker thread" {. worker_thread counter2; };
#
thread_exit { success => TRUE };
};
task = make_task "Test microthread pre-emptive timeslicing" [ ("startup_thread", initialize__timeslicing__task) ];
sleep_for 1.0; # Let the two worker threads run for a second.
kill_task { task, success => TRUE }; # Shut down the worker threads:
assert (*mps::alarm_handler_calls > 30); # We usually timeslice at 50Hz, so we expect alarm_handler to have been called about 50 times.
assert (*counter1 > 0); # We expect both worker threads to have done at least one work unit.
assert (*counter2 > 0); # This also guarantees a trouble report when next test cannot run due to divide-by-zero.
if (*counter1 > 0
or *counter2 > 0)
#
# Compute lesser/greater ratio, which will be
# between 0.0 and 1.0 inclusive:
#
i2f = eight_byte_float::from_int;
#
f1 = i2f *counter1;
f2 = i2f *counter2;
#
ratio = (f1 > f2) ?? f2 / f1 # Avoid divide-by-zero if (only) one of the counts is zero.
:: f1 / f2;
assert (ratio > 0.1); # We expect about 1.0. If one thread got < 10% as many CPU cycles as the other something is definitely wedged.
fi;
};
fun test_basic_microthread_switch_lock_functionality ()
=
{
# This refcell gets incremented when the primary hostthread
# (the one running microthread-preemptive-scheduler.pkg)
# acquires a hostthread-level mutex, and decremented when
# it releases it.
#
assert (*runtime::microthread_switch_lock_refcell__global == 0); # Should be zero initially.
mutex = hth::make_mutex ();
hth::acquire_mutex mutex;
assert (*runtime::microthread_switch_lock_refcell__global == 1); # Should be one now.
hth::release_mutex mutex;
assert (*runtime::microthread_switch_lock_refcell__global == 0); # Should be back to zero now.
# Doing the same thing in any other hostthread should
# result in the counter NOT incrementing:
# [ LATER ]: I've commented out this test because it
# fails a few percent of the times it is run.
#
# I doubt this is a bug in the implementation, which
# is quite simple; I presume it is because background
# I/O processing can result in
# runtime::microthread_switch_lock_refcell__global
# just happening to be set when we make our test.
#
# I don't see an easy fix, and I don't see the game
# as being worth the candle, so I've just commented it out.
#
# If you have a good replacement test for this, by all means
# post it to the list or email it to me! :-)
# maildrop = make_empty_maildrop (): Maildrop(Int);
#
# io::do {.
#
# hth::acquire_mutex mutex; # Acquire mutex in a different hostthread.
#
# i = *runtime::microthread_switch_lock_refcell__global; # Check lock refcell.
#
# hth::release_mutex mutex; # Release mutex.
#
# mps::do {.
# put_in_maildrop (maildrop, i); # Phone result back to home base.
# };
# };
#
# i = take_from_maildrop maildrop; # Get phoned result.
#
# assert (i == 0);
hth::free_mutex mutex;
};
fun run_perfect_number_loop_torture_test ()
=
loop (1, 2) # Change '2' to 10000 or such for an actual torture test.
# {
# printf "8";
# # log::note_on_stderr {. "run_perfect_number_loop_torture_test/AAA -- threadkit-unit-test.pkg\n"; };
# loop (1, 2); # Change '2' to 10000 or such for an actual torture test.
# printf "9";
# # log::note_on_stderr {. "run_perfect_number_loop_torture_test/ZZZ -- threadkit-unit-test.pkg\n"; };
# }
where
# Compute perfect numbers in a loop, delegating the inner loop
# to a secondary hostthread. This was hanging originally due
# to improper locking at the microthread/hostthread interface.
#
# The default (1, 2) parameters above do not constitute a
# torture test; we compile and run here just as protection
# against bitrot.
#
fun io_do (task: Void -> Void) = { hth::acquire_mutex io::mutex;
io::external_request_queue := (io::DO_TASK task) ! *io::external_request_queue;
hth::release_mutex io::mutex;
hth::broadcast_condvar io::condvar;
};
fun mps_do (thunk: Void -> Void)
=
{ hth::acquire_mutex mps::mutex;
mps::request_queue := (mps::DO_THUNK thunk) ! *mps::request_queue;
hth::release_mutex mps::mutex;
hth::broadcast_condvar mps::condvar;
};
fun is_perfect_number n
=
{ sum_of_nonself_factors
=
for (i = 1, sum = 0; i < n; ++i; sum) {
#
sum = (n % i == 0) ?? (sum + i) :: sum;
};
n == sum_of_nonself_factors;
};
maildrop = make_empty_maildrop (): Maildrop(Bool);
fun loop (i, c)
=
{
io_do {.
b = is_perfect_number i; # Do most of the work in a secondary hostthread.
mps_do {.
put_in_maildrop (maildrop, b); # Send result back to main hostthread.
};
};
if (take_from_maildrop maildrop) # Receive result in main hostthread.
#
assert (i == 8128 or # Verify that numbers reported as perfect actually are.
i == 496 or
i == 28 or
i == 6);
# printf "%b is perfect!\n" i; # So you can see the 110 11100 ... binary structure.
fi;
#
if (i == 1) if (c > 1) loop (10000, c - 1); fi;
else loop (i - 1, c );
fi;
};
end;
fun test_basic_ximp_functionality ()
=
{ (make_run_gun ()) -> { run_gun', fire_run_gun };
(make_end_gun ()) -> { end_gun', fire_end_gun };
# Create a binary tree looking like
#
# 1
# / \
# 2 3
# / \ \
# 4 5 6
# /
# 7
#
bxegg1 = bx::make_binarytree_egg (1,[]); (bxegg1 ()) -> (bxports1, bxegg1'); bx1 = bxports1.binarytree_port;
bxegg2 = bx::make_binarytree_egg (2,[]); (bxegg2 ()) -> (bxports2, bxegg2'); bx2 = bxports2.binarytree_port;
bxegg3 = bx::make_binarytree_egg (3,[]); (bxegg3 ()) -> (bxports3, bxegg3'); bx3 = bxports3.binarytree_port;
bxegg4 = bx::make_binarytree_egg (4,[]); (bxegg4 ()) -> (bxports4, bxegg4'); bx4 = bxports4.binarytree_port;
bxegg5 = bx::make_binarytree_egg (5,[]); (bxegg5 ()) -> (bxports5, bxegg5'); bx5 = bxports5.binarytree_port;
bxegg6 = bx::make_binarytree_egg (6,[]); (bxegg6 ()) -> (bxports6, bxegg6'); bx6 = bxports6.binarytree_port;
bxegg7 = bx::make_binarytree_egg (7,[]); (bxegg7 ()) -> (bxports7, bxegg7'); bx7 = bxports7.binarytree_port;
# This is a very handy little debug fn
# which is used by scattering lines like
#
# if *log::debugging log::note_on_stderr {. sprintf "%s\ttest_basic_ximp_functionality/CCC1 -- configuring node 1" (log::debug_statestring()); }; fi;
#
# through the code in question and then to enable them doing
#
# log::debugging := TRUE;
#
# fun debug_statestring ()
# =
# sprintf "%26s %s\t%s %s/%s %s/%s"
# (log::get_current_microthread's_name())
# (mps::thread_scheduler_statestring())
# (maildrop_to_string (run_gun,"gun"))
# (mailqueue_to_string ((bx::clientport_to_mailqueue bx5),"bx5")) (replyqueue_to_string (bxports5.replyqueue,"bx5"))
# (mailqueue_to_string ((bx::clientport_to_mailqueue bx7),"bx7")) (replyqueue_to_string (bxports7.replyqueue,"bx7"))
# ;
#
# log::debug_statestring__hook := debug_statestring;
# Wire up imp our imps:
#
bxegg1' ({ leftkid => THE bx2, rightkid => THE bx3 }, run_gun', end_gun' );
bxegg2' ({ leftkid => THE bx4, rightkid => THE bx5 }, run_gun', end_gun' );
bxegg3' ({ leftkid => NULL, rightkid => THE bx6 }, run_gun', end_gun' );
bxegg4' ({ leftkid => NULL, rightkid => NULL }, run_gun', end_gun' );
bxegg5' ({ leftkid => THE bx7, rightkid => NULL }, run_gun', end_gun' );
bxegg6' ({ leftkid => NULL, rightkid => NULL }, run_gun', end_gun' );
bxegg7' ({ leftkid => NULL, rightkid => NULL }, run_gun', end_gun' );
fire_run_gun (); # Start all app imps running.
assert ((bx4.get_subtree_sum ()) == 4); # Many calls like this over lifetime of imp.
assert ((bx6.get_subtree_sum ()) == 6); # Many calls like this over lifetime of imp.
assert ((bx7.get_subtree_sum ()) == 7); # Many calls like this over lifetime of imp.
assert ((bx3.get_subtree_sum ()) == 9); # Many calls like this over lifetime of imp.
assert ((bx5.get_subtree_sum ()) == 12); # Many calls like this over lifetime of imp.
assert ((bx2.get_subtree_sum ()) == 18); # Many calls like this over lifetime of imp.
assert ((bx1.get_subtree_sum ()) == 28); # Many calls like this over lifetime of imp.
fire_end_gun (); # Have all app imps shut down.
};
fun run ()
=
{ printf "\nDoing %s:\n" name;
#
test_basic_mailslot_functionality_c ();
test_basic_mailslot_functionality_a ();
test_basic_mailslot_functionality_b ();
test_basic_maildrop_functionality ();
test_basic_mailqueue_functionality ();
test_basic_mailcaster_functionality ();
test_basic_thread_local_property_functionality ();
test_basic_timeout_functionality ();
test_basic_select_functionality ();
test_basic_succeed_vs_fail_functionality ();
test_basic_preemptive_scheduling_fairness ();
test_basic_microthread_switch_lock_functionality ();
run_perfect_number_loop_torture_test ();
test_basic_ximp_functionality ();
summarize_unit_tests name;
};
};
end;
## Code by Jeff Prothero: Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.