## thread-scheduler-control-g.pkg
# Compiled by:
# src/lib/std/standard.lib # winix is from src/lib/std/winix.pkg # winix_guts is from src/lib/std/src/posix/winix-guts.pkg # winix_process is from src/lib/std/src/posix/winix-process.pkgstipulate
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 package cu = threadkit_startup_and_shutdown_hooks; # threadkit_startup_and_shutdown_hooks is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit-startup-and-shutdown-hooks.pkg package fat = fate; # fate is from src/lib/std/src/nj/fate.pkg package ri = runtime_internals; # runtime_internals is from src/lib/std/src/nj/runtime-internals.pkg package rs = runtime_signals; # runtime_signals is from src/lib/std/src/nj/runtime-signals.pkg package sig = runtime_signals; # runtime_signals is from src/lib/std/src/nj/runtime-signals.pkg package thr = thread; # thread is from src/lib/src/lib/thread-kit/src/core-thread-kit/thread.pkg package ts = thread_scheduler; # thread_scheduler is from src/lib/src/lib/thread-kit/src/core-thread-kit/thread-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.pkgherein
# 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 {
# Force hook initialization
# to link (and thus execute):
#
include initialize_threadkit_startup_and_shutdown_hooks;
include cu;
# initialize_threadkit_startup_and_shutdown_hooks is from src/lib/src/lib/thread-kit/src/glue/initialize-threadkit-startup-and-shutdown-hooks.pkg package xpt = threadkit_export_function_g( drv ); # threadkit_export_function_g is from src/lib/src/lib/thread-kit/src/glue/threadkit-export-function-g.pkg fun cfun fun_name
=
ci::find_c_function { lib_name => "heap", fun_name }; # "heap" def in src/c/lib/heap/libmythryl-heap.c
is_running
=
tsr::thread_scheduler_is_running;
fun thread_scheduler_is_running ()
=
*is_running;
fun shut_down_thread_scheduler status
=
if *is_running
#
fat::resume_fate *ts::shutdown_hook (TRUE, status);
else
raise exception FAIL "threadkit is not running";
fi;
#
fun dummy_print _ # Dummy print function, in case the user's program doesn't reference threadkit's file package directly.
=
raise exception FAIL "print called without loading threadkit's file";
my interrupt_fate: fat::Fate( Void )
=
fat::make_isolated_fate
(fn _ = shut_down_thread_scheduler winix::process::failure);
fun start_up_thread_scheduler''
( first_thread_thunk, # Thunk for initial thread to run.
time_quantum # THE timeslicing time quantum. If NULL, defaults to 20 milliseconds.
)
=
{ saved_interrupt_handler
=
sig::get_signal_handler
sig::interrupt_signal;
saved_print_function
=
*ri::print_hook; # runtime_internals is from src/lib/std/src/nj/runtime-internals.pkg if *is_running
raise exception FAIL "threadkit is already running";
fi;
is_running := TRUE;
thr::reset 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 # poll_fate def in src/lib/src/lib/thread-kit/src/glue/threadkit-export-function-g.pkg # pause_fate def in src/lib/src/lib/thread-kit/src/glue/threadkit-export-function-g.pkg ts::scheduler_hook := xpt::poll_fate ;
ts::pause_hook := xpt::pause_fate;
my (clean_up, status)
=
fat::call_with_current_fate
( fn done_fate
=
{ sig::set_signal_handler
( sig::interrupt_signal,
sig::HANDLER (fn _ = interrupt_fate)
);
ts::shutdown_hook := done_fate;
ri::print_hook := dummy_print;
case time_quantum
#
THE time_quantum => ts::start_thread_scheduler_timer time_quantum;
_ => ts::restart_thread_scheduler_timer ();
esac;
cu::do_actions_for cu::STARTUP;
#####################################
# This is where we actually enter
# concurrent programming mode,
# initially with a single thread
# running the first_thread_thunk:
#####################################
#
thr::make_thread "thread_scheduler_control start_up" first_thread_thunk;
#
ts::dispatch_next_thread ();
}
);
#####################################
# At this point we have exited
# concurrent programming mode
# and are returning to vanilla
# single-threaded operation.
#####################################
cu::do_actions_for cu::THREADKIT_SHUTDOWN;
drv::stop_threadkit_driver ();
ts::stop_thread_scheduler_timer ();
thr::reset FALSE;
is_running := FALSE;
ri::print_hook
:=
saved_print_function;
sig::set_signal_handler
#
(sig::interrupt_signal, saved_interrupt_handler);
status;
};
fun start_up_thread_scheduler
first_thread_thunk
=
start_up_thread_scheduler''
( first_thread_thunk, # Thunk for initial thread to run.
NULL # THE timeslicing time quantum. If NULL, defaults to 20 milliseconds.
);
fun start_up_thread_scheduler'
time
first_thread_thunk
=
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.
);
# 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 thread_scheduler
first_thread_thunk
=
if *is_running
#
first_thread_thunk ();
();
else
start_up_thread_scheduler .{
#
first_thread_thunk ();
shut_down_thread_scheduler 0;
};
(); # Return Void.
fi;
stipulate
Cmdt = xpt::Pair (String, List( String ) )
->
winix::process::Status;
herein
#
spawn_to_disk' = cfun "spawn_to_disk" : (String, Cmdt) -> Void;
end;
fun spawn_to_disk (file_name, main, time_q)
=
{ if (not *is_running)
#
is_running := TRUE;
else
raise exception FAIL "Cannot spawn_to_disk while threadkit is running";
fi;
rs::mask_signals rs::MASK_ALL;
# Run the Lib7 SPAWN_TO_DISK at-functions
# to avoid some space-leaks:
#
ri::at::run_functions_scheduled_to_run
#
ri::at::SPAWN_TO_DISK;
# Strip out any unecessary stuff from
# the threadkit Cleanup state:
#
cu::export_fn_cleanup ();
# Unlink the SML print function:
#
ri::print_hook
:=
(fn _ = ());
# Clear the pervasive package list
# of picklehash-pickle pairs:
#
uns::pervasive_package_pickle_list__global
:=
uns::p::NIL;
# Now export the wrapped main function:
#
spawn_to_disk' (file_name, xpt::wrap_for_export (main, time_q));
};
};
end;
## COPYRIGHT (c) 1989-1991 John H. Reppy
## COPYRIGHT (c) 1996 AT&T Research.
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2012,
## released under Gnu Public Licence version 3.