## thread-scheduler-control-g.pkg
#
# Compiled by:
# src/lib/std/standard.lib # winix_guts is from src/lib/std/src/posix/winix-guts.pkg # winix_process__premicrothread is from src/lib/std/src/posix/winix-process--premicrothread.pkgstipulate
package at = run_at__premicrothread; # run_at__premicrothread is from src/lib/std/src/nj/run-at--premicrothread.pkg package cu = run_at; # run_at is from src/lib/src/lib/thread-kit/src/core-thread-kit/run-at.pkg package fat = fate; # fate is from src/lib/std/src/nj/fate.pkg package is = interprocess_signals; # interprocess_signals is from src/lib/std/src/nj/interprocess-signals.pkg package itt = internal_threadkit_types; # internal_threadkit_types is from src/lib/src/lib/thread-kit/src/core-thread-kit/internal-threadkit-types.pkg package ri = runtime_internals; # runtime_internals is from src/lib/std/src/nj/runtime-internals.pkg package th = microthread; # microthread is from src/lib/src/lib/thread-kit/src/core-thread-kit/microthread.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 tsr = thread_scheduler_is_running; # thread_scheduler_is_running is from src/lib/src/lib/thread-kit/src/core-thread-kit/thread-scheduler-is-running.pkg package uns = unsafe; # unsafe is from src/lib/std/src/unsafe/unsafe.pkg package wnx = winix__premicrothread; # winix__premicrothread is from src/lib/std/winix--premicrothread.pkg package wxp = winix__premicrothread::process; # winix__premicrothread::process is from src/lib/std/src/posix/winix-process--premicrothread.pkg #
package ci = unsafe::mythryl_callable_c_library_interface; # unsafe is from src/lib/std/src/unsafe/unsafe.pkg # mythryl_callable_c_library_interface is from src/lib/std/src/unsafe/mythryl-callable-c-library-interface.pkg fun cfun fun_name
=
ci::find_c_function { lib_name => "heap", fun_name }; # "heap" def in src/c/lib/heap/libmythryl-heap.c
#
###############################################################
# 'cfun' here is used only for spawn_to_disk which should be called
# only on a quiescient system with only one active posix thread, so
# our usual latency-minimization reasons for indirecting
# syscalls through other posix threads do not apply.
#
# Consequently I'm not taking the time and effort to switch it
# over from using find_c_function() to using find_c_function'().
# -- 2012-04-21 CrT
herein
# This generic is invoked (only) by:
#
# src/lib/src/lib/thread-kit/src/posix/thread-scheduler-control.pkg #
generic package thread_scheduler_control_g (
# ==========================
#
drv: Threadkit_Driver_For_Os # Threadkit_Driver_For_Os is from src/lib/src/lib/thread-kit/src/posix/threadkit-driver-for-os.api # threadkit_driver_for_posix is from src/lib/src/lib/thread-kit/src/posix/threadkit-driver-for-posix.pkg )
: (weak) Thread_Scheduler_Control # Thread_Scheduler_Control is from src/lib/src/lib/thread-kit/src/glue/thread-scheduler-control.api {
# initialize_run_at is from src/lib/src/lib/thread-kit/src/glue/initialize-run-at.pkg # These all get re-exported to clients:
#
exception NO_SUCH_ACTION = cu::NO_SUCH_ACTION;
When == cu::When;
when_to_string = cu::when_to_string;
note_startup_or_shutdown_action = cu::note_startup_or_shutdown_action;
forget_startup_or_shutdown_action = cu::forget_startup_or_shutdown_action;
note_mailqueue = cu::note_mailqueue;
forget_mailqueue = cu::forget_mailqueue;
note_mailslot = cu::note_mailslot;
forget_mailslot = cu::forget_mailslot;
forget_all_mailslots_mailqueues_and_imps= cu::forget_all_mailslots_mailqueues_and_imps;
note_imp = cu::note_imp;
forget_imp = cu::forget_imp;
stipulate
# Force hook initialization
# to link (and thus execute):
#
package iss = initialize_run_at; # initialize_run_at is from src/lib/src/lib/thread-kit/src/glue/initialize-run-at.pkg package bas = threadkit_base_for_os_g( drv ); # threadkit_base_for_os_g is from src/lib/src/lib/thread-kit/src/glue/threadkit-base-for-os-g.pkg herein #
saved_interrupt_handler = REF is::IGNORE;
saved_print_function = REF *ri::print_hook; # runtime_internals is from src/lib/std/src/nj/runtime-internals.pkg# is_running
# =
# tsr::thread_scheduler_is_running;
# fun thread_scheduler_is_running ()
# =
# tsr::thread_scheduler_is_running ();
#
fun shut_down_thread_scheduler status # This is currently called at the end of all threadkit-using applications.
=
if (tsr::thread_scheduler_is_running ()
and (not *tsr::started_thread_scheduler_shutdown))
#
fat::switch_to_fate *mps::thread_scheduler_shutdown_hook (TRUE, status); #
else
raise exception DIE "threadkit is not running"; # It is too hard to avoid calling this redundantly during shutdown, at least at the moment. -- 2012-08-02 CrT
fi;
#
fun dummy_print _ # Dummy print function, in case the user's program doesn't reference threadkit's file package directly.
=
raise exception DIE "print called without loading threadkit's file -- thread-scheduler-control-g.pkg";
interrupt_fate
=
fat::make_isolated_fate (\\ _ = shut_down_thread_scheduler wnx::process::failure)
:
fat::Fate( Void );
#
fun start_up_thread_scheduler'' # This is an internal routine -- not externally visible.
( first_thread_thunk, # Thunk for initial thread to run.
time_quantum # THE timeslicing time quantum. If NULL, defaults to 20 milliseconds.
)
=
{ saved_interrupt_handler
:=
is::get_signal_handler is::SIGINT;
saved_print_function
:=
*ri::print_hook; # runtime_internals is from src/lib/std/src/nj/runtime-internals.pkg# Can't do this because 'fil::' introduces cyclic package dependencies.
# ri::print_hook
# :=
# fil::print; # Install the concurrency-friendly version of 'print'.
if (tsr::thread_scheduler_is_running ())
#
raise exception DIE "threadkit is already running";
fi;
tsr::thread_scheduler_is_running_as_pid # Remember that thread scheduler is now running.
:=
THE (wxp::get_process_id ());
tsr::started_thread_scheduler_shutdown
:=
FALSE;
th::reset_thread_package { running => TRUE };
drv::start_threadkit_driver (); # Empty out the timeout queue.
# threadkit_driver_for_posix is from src/lib/src/lib/thread-kit/src/posix/threadkit-driver-for-posix.pkg # wake_sleeping_threads_and_schedule_fd_io_and_harvest_dead_subprocesses__xu__fate is from src/lib/src/lib/thread-kit/src/glue/threadkit-base-for-os-g.pkg # no_runnable_threads_left__fate is from src/lib/src/lib/thread-kit/src/glue/threadkit-base-for-os-g.pkg mps::run_next_runnable_thread__xu__hook := bas::wake_sleeping_threads_and_schedule_fd_io_and_harvest_dead_subprocesses__xu__fate;
mps::no_runnable_threads_left__hook := bas::no_runnable_threads_left__fate;
my (clean_up, status)
=
fat::call_with_current_fate
( \\ done_fate
=
{ is::set_signal_handler
( is::SIGINT,
is::HANDLER (\\ _ = interrupt_fate)
);
mps::thread_scheduler_shutdown_hook := done_fate;
ri::print_hook := dummy_print;
case time_quantum
#
THE time_quantum => mps::start_thread_scheduler_timer time_quantum;
_ => mps::restart_thread_scheduler_timer ();
esac;
cu::do_actions_for cu::COMPILER_STARTUP;
#####################################
# This is where we actually enter
# concurrent programming mode,
# initially with a single thread
# running the first_thread_thunk:
#####################################
#
# th::make_thread "default thread" first_thread_thunk;
itt::default_task -> itt::APPTASK { alive_threads_count, ... };
mps::assert_not_in_uninterruptible_scope "start_up_thread_scheduler''";
log::uninterruptible_scope_mutex := 1;
#
alive_threads_count := *alive_threads_count + 1;
th::run_thread__xu itt::default_thread first_thread_thunk ();
#
mps::dispatch_next_thread__noreturn ();
}
);
#####################################
# At this point we have exited
# concurrent programming mode
# and are returning to vanilla
# single-threaded operation.
#####################################
if (tsr::thread_scheduler_is_running () # Try to be robust against different shutdown sequences etc.
and (not *tsr::started_thread_scheduler_shutdown)
)
#
tsr::started_thread_scheduler_shutdown := TRUE;
# Compare this block with corresponding block in wrap_for_export() from src/lib/src/lib/thread-kit/src/glue/threadkit-base-for-os-g.pkg #
cu::do_actions_for cu::THREADKIT_SHUTDOWN; # Lets various imps clean up, for example by closing X sockets in src/lib/x-kit/xclient/src/wire/socket-closer-imp-old.pkg drv::stop_threadkit_driver (); # Merely clears the timeout-mailop.pkg list of threads waiting for timeouts.
# #
mps::stop_thread_scheduler_timer (); # Stops 50Hz SIGALRM, sets alarm_signal handler to IGNORE.
th::reset_thread_package { running => FALSE }; # microthread.pkg: tid_count := 0; microthread-preemptive-scheduler.pkg: Clears hooks, queues, cached time, current thread.
tsr::thread_scheduler_is_running_as_pid # Thread scheduler is no longer running.
:=
NULL;
ri::print_hook
:=
*saved_print_function;
is::set_signal_handler
#
(is::SIGINT, *saved_interrupt_handler);
();
# else
# printf "start_up_thread_scheduler'' shutdown half/BBB mode d=%d: thread scheduler was not running.\n" (mps::get_uninterruptible_scope_nesting_depth());
fi;
# printf "start_up_thread_scheduler'' shutdown half/ZZZ mode d=%d\n" (mps::get_uninterruptible_scope_nesting_depth());
status;
};
#
fun start_up_thread_scheduler # Exported.
(first_thread_thunk: Void -> Void)
=
{
# printf "start_up_thread_scheduler/TOP mode d=%d -- thread-scheduler-control-g.pkg\n" (mps::get_uninterruptible_scope_nesting_depth());
if (tsr::thread_scheduler_is_running ())
#
# printf "start_up_thread_scheduler/AAA: mode d=%d thread scheduler is running, calling first_thread_thunk -- thread-scheduler-control-g.pkg\n" (mps::get_uninterruptible_scope_nesting_depth());
{ first_thread_thunk ();
# printf "start_up_thread_scheduler/BBB: mode d=%d thread scheduler is running, back from calling first_thread_thunk -- thread-scheduler-control-g.pkg\n" (mps::get_uninterruptible_scope_nesting_depth());
winix__premicrothread::process::success;
}
except
_ = winix__premicrothread::process::failure;
else
# printf "start_up_thread_scheduler/MMM: mode d=%d thread scheduler is NOT running, calling start_up_thread_scheduler'' thunk -- thread-scheduler-control-g.pkg\n" (mps::get_uninterruptible_scope_nesting_depth());
result =
start_up_thread_scheduler''
( first_thread_thunk, # Thunk for initial thread to run.
NULL # THE timeslicing time quantum. If NULL, defaults to 20 milliseconds.
);
# printf "start_up_thread_scheduler/NNN: mode d=%d thread scheduler is NOT running, back from calling start_up_thread_scheduler'' thunk -- thread-scheduler-control-g.pkg\n" (mps::get_uninterruptible_scope_nesting_depth());
result;
fi;
};
#
fun start_up_thread_scheduler' # Exported.
time
(first_thread_thunk: Void -> Void)
=
if (tsr::thread_scheduler_is_running ())
#
{ first_thread_thunk ();
winix__premicrothread::process::success;
}
except
_ = winix__premicrothread::process::failure;
else
start_up_thread_scheduler''
( first_thread_thunk, # Thunk for initial thread to run.
THE time # THE timeslicing time quantum. If NULL, defaults to 20 milliseconds.
);
fi;
# Run given first_thread_thunk with
# threadkit concurrency support.
#
# Make life easy for the user by
# nesting cleanly -- we start up
# threadkit only if needed, if it
# is already running we just run
# the thunk and return:
#
fun run_under_thread_scheduler
first_thread_thunk
=
if (tsr::thread_scheduler_is_running ())
#
first_thread_thunk ();
();
else
start_up_thread_scheduler {.
#
first_thread_thunk ();
shut_down_thread_scheduler 0;
};
(); # Return Void.
fi;
#################################################################3
# This stuff added 2012-07-29 CrT to make Mythryl
# multi-threaded by default instead of optionally:
#
my _ =
{
if TRUE
fun start_up_thread_scheduler''' ()
=
fat::call_with_current_fate
(\\ my_fate
=
{ fun my_thunk ()
=
fat::switch_to_fate my_fate ();
# printf "start_up_thread_scheduler''' calling start_up_thread_scheduler'' ... \n";
result
=
start_up_thread_scheduler'' (my_thunk, NULL);
# printf "start_up_thread_scheduler''' back from calling start_up_thread_scheduler'', now calling ====> winix__premicrothread::process::exit <====... \n";
winix__premicrothread::process::exit result;
();
}
);
fun start_up_thread_scheduler'''' _ # The ignored arg here will be at::STARTUP_PHASE_12_START_THREAD_SCHEDULER.
=
{
# printf "start_up_thread_scheduler''''/top mode d=%d\n" (mps::get_uninterruptible_scope_nesting_depth());
start_up_thread_scheduler''' ();
};
fun shut_down_thread_scheduler'''' _ # The ignored arg here will be at::SHUTDOWN_PHASE_3_STOP_THREAD_SCHEDULER.
=
{
# printf "shut_down_thread_scheduler''''/TOP\n";
if (tsr::thread_scheduler_is_running () # Try to be robust against different shutdown sequences etc.
and (not *tsr::started_thread_scheduler_shutdown)
)
#
tsr::started_thread_scheduler_shutdown := TRUE;
# Compare this block with corresponding block in wrap_for_export() from src/lib/src/lib/thread-kit/src/glue/threadkit-base-for-os-g.pkg #
# printf "shut_down_thread_scheduler''''/AAA: cu::do_actions_for cu::THREADKIT_SHUTDOWN\n";
cu::do_actions_for cu::THREADKIT_SHUTDOWN; # Lets various imps clean up, for example by closing X sockets in src/lib/x-kit/xclient/src/wire/socket-closer-imp-old.pkg# printf "shut_down_thread_scheduler''''/BBB: drv::stop_threadkit_driver ()\n";
drv::stop_threadkit_driver (); # Merely clears the timeout-mailop.pkg list of threads waiting for timeouts.
# #
# printf "shut_down_thread_scheduler''''/CCC: mps::stop_thread_scheduler_timer ()\n";
mps::stop_thread_scheduler_timer (); # Stops 50Hz SIGALRM, sets alarm_signal handler to IGNORE.
# printf "shut_down_thread_scheduler''''/DDD: th::reset_thread_package { running => FALSE }\n";
th::reset_thread_package { running => FALSE }; # microthread.pkg: tid_count := 0; microthread-preemptive-scheduler.pkg: Clears hooks, queues, cached time, current thread.
tsr::thread_scheduler_is_running_as_pid # Thread scheduler is no longer running.
:=
NULL;
ri::print_hook
:=
*saved_print_function;
is::set_signal_handler
#
(is::SIGINT, *saved_interrupt_handler);
# printf "shut_down_thread_scheduler''''/ZZZ\n";
();
fi;
};
# OLD -- doesn't return, and to run all shutdown actions in sequence various places we need this to return
# shut_down_thread_scheduler winix__premicrothread::process::success;
at::schedule ("thread-scheduler-control-g.pkg: start up thread scheduler", [ at::STARTUP_PHASE_12_START_THREAD_SCHEDULER ], start_up_thread_scheduler'''' );
at::schedule ("thread-scheduler-control-g.pkg: shut down thread scheduler", [ at::SHUTDOWN_PHASE_3_STOP_THREAD_SCHEDULER ], shut_down_thread_scheduler'''' );
(); fi;
};
#
#################################################################3
stipulate
Cmdt = bas::Pair (String, List( String ))
->
wnx::process::Status;
herein
#
spawn_to_disk' = cfun "spawn_to_disk" : (String, Cmdt) -> Void;
end;
#
fun spawn_to_disk (file_name, main, time_q)
=
{ if (tsr::thread_scheduler_is_running ()) raise exception DIE "Cannot spawn_to_disk while threadkit is running"; fi;
#
tsr::thread_scheduler_is_running_as_pid # Remember that thread scheduler is now running.
:= # (WTF?! -- 2012-07-21 CrT)
THE (wxp::get_process_id ());
is::mask_signals is::MASK_ALL;
ri::at::run_functions_scheduled_to_run ri::at::SPAWN_TO_DISK; # Avoid some space-leaks.
cu::export_fn_cleanup (); # Strip out any unecessary stuff from the threadkit Cleanup state.
ri::print_hook := (\\ _ = ()); # Unlink the SML print function.
uns::pervasive_package_pickle_list__global # Clear the pervasive package list of picklehash-pickle pairs.
:=
uns::p::NIL;
spawn_to_disk' (file_name, bas::wrap_for_export (main, time_q)); # Export the wrapped main function.
};
end; # stipulate
};
end;